X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fhsc2hs%2FMain.hs;h=77b948f37a902cc129b927e606f9d8c447c9f878;hb=287035073628a3f59f5aa421f66abe8c6058dd64;hp=4b39e4a7bb5c8fe8070c08b228bae3480360fd18;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/utils/hsc2hs/Main.hs b/utils/hsc2hs/Main.hs index 4b39e4a..77b948f 100644 --- a/utils/hsc2hs/Main.hs +++ b/utils/hsc2hs/Main.hs @@ -13,7 +13,7 @@ #include "../../includes/ghcconfig.h" #endif -#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 || __HUGS__ +#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 import System.Console.GetOpt #else import GetOpt @@ -24,9 +24,9 @@ import Directory (removeFile,doesFileExist) import Monad (MonadPlus(..), liftM, liftM2, when) import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord) import List (intersperse, isSuffixOf) -import IO (hPutStr, hPutStrLn, stderr) +import IO (hPutStr, hPutStrLn, stderr, bracket_) -#if defined(mingw32_HOST_OS) && !__HUGS__ +#if defined(mingw32_HOST_OS) import Foreign #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 import Foreign.C.String @@ -35,7 +35,6 @@ import CString #endif #endif - #if __GLASGOW_HASKELL__ >= 604 import System.Process ( runProcess, waitForProcess ) import System.IO ( openFile, IOMode(..), hClose ) @@ -43,16 +42,20 @@ import System.IO ( openFile, IOMode(..), hClose ) #endif #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC) -import Compat.RawSystem ( rawSystem ) +#ifdef USING_COMPAT +import Compat.RawSystem ( rawSystem ) +#else +import System.Cmd ( rawSystem ) +#endif #define HAVE_rawSystem -#elif __HUGS__ || __NHC__ >= 117 +#elif __NHC__ >= 117 import System.Cmd ( rawSystem ) #define HAVE_rawSystem #endif #if !defined(HAVE_runProcess) || !defined(HAVE_rawSystem) -- we need system -#if __HUGS__ || __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600 +#if __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600 import System.Cmd ( system ) #else import System ( system ) @@ -118,7 +121,6 @@ options = [ "display this help and exit", Option ['V'] ["version"] (NoArg Version) "output version information and exit" ] - main :: IO () main = do @@ -129,26 +131,22 @@ main = do -- If there is no Template flag explicitly specified, try -- to find one by looking near the executable. This only - -- works on Win32 or Hugs (getExecDir). On Unix, there's a wrapper + -- works on Win32 or Hugs (getExecDir). On Unix, there's a wrapper -- script which specifies an explicit template flag. flags_w_tpl <- if any template_flag flags then return flags - else -#ifdef __HUGS__ - do mb_path <- getExecDir "/Main.hs" -#else + else do mb_path <- getExecDir "/bin/hsc2hs.exe" -#endif add_opt <- case mb_path of Nothing -> return id Just path -> do let templ = path ++ "/template-hsc.h" flg <- doesFileExist templ - if flg + if flg then return ((Template templ):) else return id - return (add_opt flags) + return (add_opt flags) case (files, errs) of (_, _) | any isHelp flags_w_tpl -> bye (usageInfo header options) @@ -172,7 +170,7 @@ die :: String -> IO a die s = hPutStr stderr s >> exitWith (ExitFailure 1) processFile :: [Flag] -> String -> IO () -processFile flags name +processFile flags name = do let file_name = dosifyPath name s <- readFile file_name case parser of @@ -505,7 +503,7 @@ splitExt name = output :: [Flag] -> String -> [Token] -> IO () output flags name toks = do - + (outName, outDir, outBase) <- case [f | Output f <- flags] of [] -> if not (null ext) && last ext == 'c' then return (dir++base++init ext, dir, base) @@ -521,7 +519,7 @@ output flags name toks = do (base, _) = splitExt file in return (f, dir, base) _ -> onlyOne "output file" - + let cProgName = outDir++outBase++"_hsc_make.c" oProgName = outDir++outBase++"_hsc_make.o" progName = outDir++outBase++"_hsc_make" @@ -533,34 +531,23 @@ output flags name toks = do outHFile = outBase++"_hsc.h" outHName = outDir++outHFile outCName = outDir++outBase++"_hsc.c" - + beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags let execProgName | null outDir = dosifyPath ("./" ++ progName) | otherwise = progName - + let specials = [(pos, key, arg) | Special pos key arg <- toks] - + let needsC = any (\(_, key, _) -> key == "def") specials needsH = needsC - + let includeGuard = map fixChar outHName where fixChar c | isAlphaNum c = toUpper c | otherwise = '_' -#ifdef __HUGS__ - compiler <- case [c | Compiler c <- flags] of - [] -> return "gcc" - [c] -> return c - _ -> onlyOne "compiler" - - linker <- case [l | Linker l <- flags] of - [] -> return compiler - [l] -> return l - _ -> onlyOne "linker" -#else -- Try locating GHC..on Win32, look in the vicinity of hsc2hs. -- Returns a native-format path locateGhc def = do @@ -570,15 +557,15 @@ output flags name toks = do Just x -> do let ghc_path = dosifyPath (x ++ "bin/ghc.exe") flg <- doesFileExist ghc_path - if flg + if flg then return ghc_path else return def - - -- On a Win32 installation we execute the hsc2hs binary directly, + + -- On a Win32 installation we execute the hsc2hs binary directly, -- with no --cc flags, so we'll call locateGhc here, which will -- succeed, via getExecDir. -- - -- On a Unix installation, we'll run the wrapper script hsc2hs.sh + -- On a Unix installation, we'll run the wrapper script hsc2hs.sh -- (called plain hsc2hs in the installed tree), which will pass -- a suitable C compiler via --cc -- @@ -588,12 +575,11 @@ output flags name toks = do [] -> locateGhc "ghc" [c] -> return c _ -> onlyOne "compiler" - + linker <- case [l | Linker l <- flags] of [] -> locateGhc compiler [l] -> return l _ -> onlyOne "linker" -#endif writeFile cProgName $ concatMap outFlagHeaderCProg flags++ @@ -603,43 +589,30 @@ output flags name toks = do outHsLine (SourcePos name 0)++ concatMap outTokenHs toks++ " return 0;\n}\n" - + -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code, -- so we use something slightly more complicated. :-P when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $ exitWith ExitSuccess - - - compilerStatus <- rawSystemL beVerbose compiler + rawSystemL ("compiling " ++ cProgName) beVerbose compiler ( ["-c"] ++ [f | CompFlag f <- flags] ++ [cProgName] ++ ["-o", oProgName] ) + finallyRemove cProgName $ do - case compilerStatus of - e@(ExitFailure _) -> exitWith e - _ -> return () - removeFile cProgName - - linkerStatus <- rawSystemL beVerbose linker + rawSystemL ("linking " ++ oProgName) beVerbose linker ( [f | LinkFlag f <- flags] ++ [oProgName] ++ ["-o", progName] ) + finallyRemove oProgName $ do + + rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName + finallyRemove progName $ do - case linkerStatus of - e@(ExitFailure _) -> exitWith e - _ -> return () - removeFile oProgName - - progStatus <- rawSystemWithStdOutL beVerbose execProgName [] outName - removeFile progName - case progStatus of - e@(ExitFailure _) -> exitWith e - _ -> return () - when needsH $ writeFile outHName $ "#ifndef "++includeGuard++"\n" ++ "#define "++includeGuard++"\n" ++ @@ -654,37 +627,55 @@ output flags name toks = do concatMap outFlagH flags++ concatMap outTokenH specials++ "#endif\n" - + when needsC $ writeFile outCName $ "#include \""++outHFile++"\"\n"++ concatMap outTokenC specials -- NB. outHFile not outHName; works better when processed -- by gcc or mkdependC. -rawSystemL :: Bool -> FilePath -> [String] -> IO ExitCode -rawSystemL flg prog args = do +rawSystemL :: String -> Bool -> FilePath -> [String] -> IO () +rawSystemL action flg prog args = do let cmdLine = prog++" "++unwords args when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine) #ifndef HAVE_rawSystem - system cmdLine + exitStatus <- system cmdLine #else - rawSystem prog args + exitStatus <- rawSystem prog args #endif + case exitStatus of + ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n" + _ -> return () -rawSystemWithStdOutL :: Bool -> FilePath -> [String] -> FilePath -> IO ExitCode -rawSystemWithStdOutL flg prog args outFile = do +rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO () +rawSystemWithStdOutL action flg prog args outFile = do let cmdLine = prog++" "++unwords args++" >"++outFile when flg (hPutStrLn stderr ("Executing: " ++ cmdLine)) #ifndef HAVE_runProcess - system cmdLine + exitStatus <- system cmdLine #else hOut <- openFile outFile WriteMode process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing - res <- waitForProcess process + exitStatus <- waitForProcess process hClose hOut - return res #endif - + case exitStatus of + ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n" + _ -> return () + + +-- delay the cleanup of generated files until the end; attempts to +-- get around intermittent failure to delete files which has +-- just been exec'ed by a sub-process (Win32 only.) +finallyRemove :: FilePath -> IO a -> IO a +finallyRemove fp act = + bracket_ (return fp) + (const $ noisyRemove fp) + act + where + noisyRemove fpath = + catch (removeFile fpath) + (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e)) onlyOne :: String -> IO a onlyOne what = die ("Only one "++what++" may be specified\n") @@ -893,8 +884,6 @@ showCString = concatMap showCChar intToDigit (ord c `quot` 8 `mod` 8), intToDigit (ord c `mod` 8)] - - ----------------------------------------- -- Modified version from ghc/compiler/SysTools -- Convert paths foo/baz to foo\baz on Windows @@ -921,9 +910,7 @@ getExecDir cmd = removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath getExecPath :: IO (Maybe String) -#if defined(__HUGS__) -getExecPath = liftM Just getProgName -#elif defined(mingw32_HOST_OS) +#if defined(mingw32_HOST_OS) getExecPath = allocaArray len $ \buf -> do ret <- getModuleFileName nullPtr buf len