X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fhsc2hs%2FMain.hs;h=75ea57b555dc5a6e42842cf3b1578f9a3c0b9b3c;hb=a92db2a52d056ab962e4f55d5d8e3997ac3b8e4f;hp=a36bc40a572614840732af197a0f3aad57508272;hpb=334bc6d828327776ecb7c33b8e77e3e57f0d0d72;p=ghc-hetmet.git diff --git a/utils/hsc2hs/Main.hs b/utils/hsc2hs/Main.hs index a36bc40..75ea57b 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 ) @@ -45,14 +44,14 @@ import System.IO ( openFile, IOMode(..), hClose ) #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC) import Compat.RawSystem ( rawSystem ) #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 +117,6 @@ options = [ "display this help and exit", Option ['V'] ["version"] (NoArg Version) "output version information and exit" ] - main :: IO () main = do @@ -129,26 +127,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 +166,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 +499,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 +515,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 +527,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 +553,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 +571,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,32 +585,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 - - rawSystemL ("compiling " ++ cProgName) beVerbose compiler ( ["-c"] ++ [f | CompFlag f <- flags] ++ [cProgName] ++ ["-o", oProgName] ) - removeFile cProgName - + finallyRemove cProgName $ do + rawSystemL ("linking " ++ oProgName) beVerbose linker ( [f | LinkFlag f <- flags] ++ [oProgName] ++ ["-o", progName] ) - removeFile oProgName - + finallyRemove oProgName $ do + rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName - removeFile progName - + finallyRemove progName $ do + when needsH $ writeFile outHName $ "#ifndef "++includeGuard++"\n" ++ "#define "++includeGuard++"\n" ++ @@ -643,7 +623,7 @@ output flags name toks = do concatMap outFlagH flags++ concatMap outTokenH specials++ "#endif\n" - + when needsC $ writeFile outCName $ "#include \""++outHFile++"\"\n"++ concatMap outTokenC specials @@ -679,6 +659,19 @@ rawSystemWithStdOutL action flg prog args outFile = do 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") @@ -887,8 +880,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 @@ -915,9 +906,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