Fix retainer profiling

[ghc-hetmet.git] / utils / hsc2hs / Main.hs

diff --git a/utils/hsc2hs/Main.hs b/utils/hsc2hs/Main.hs
index 9f202fd..a5bd774 100644 (file)
--- a/utils/hsc2hs/Main.hs
+++ b/utils/hsc2hs/Main.hs
@@ -13,7 +13,7 @@
 #include "../../includes/ghcconfig.h"
 #endif
 
 #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
 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 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
 import Foreign
 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
 import Foreign.C.String

@@ -42,16 +42,20 @@ import System.IO                ( openFile, IOMode(..), hClose )
 #endif
 
 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
 #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
 #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
 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 )
 import System.Cmd              ( system )
 #else
 import System                   ( system )

@@ -129,14 +133,10 @@ main = do
        -- to find one by looking near the executable.  This only
        -- works on Win32 or Hugs (getExecDir). On Unix, there's a wrapper
        -- script which specifies an explicit template flag.
        -- to find one by looking near the executable.  This only
        -- 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
+    flags_w_tpl0 <- if any template_flag flags then

                        return flags
                   else
                        return flags
                   else

-#ifdef __HUGS__
-                       do mb_path <- getExecDir "/Main.hs"
-#else

                        do mb_path <- getExecDir "/bin/hsc2hs.exe"
                        do mb_path <- getExecDir "/bin/hsc2hs.exe"

-#endif

                           add_opt <-
                            case mb_path of
                              Nothing   -> return id
                           add_opt <-
                            case mb_path of
                              Nothing   -> return id

@@ -147,6 +147,12 @@ main = do
                                 then return ((Template templ):)
                                 else return id
                           return (add_opt flags)
                                 then return ((Template templ):)
                                 else return id
                           return (add_opt flags)

+
+    -- take only the last --template flag on the cmd line
+    let
+      (before,tpl:after) = break template_flag (reverse flags_w_tpl0)
+      flags_w_tpl = reverse (before ++ tpl : filter (not.template_flag) after)
+

     case (files, errs) of
         (_, _)
             | any isHelp    flags_w_tpl -> bye (usageInfo header options)
     case (files, errs) of
         (_, _)
             | any isHelp    flags_w_tpl -> bye (usageInfo header options)

@@ -548,17 +554,6 @@ output flags name toks = do
             fixChar c | isAlphaNum c = toUpper c
                       | otherwise    = '_'
 
             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
         -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
        -- Returns a native-format path
         locateGhc def = do

@@ -591,7 +586,6 @@ output flags name toks = do
         []  -> locateGhc compiler
         [l] -> return l
         _   -> onlyOne "linker"
         []  -> locateGhc compiler
         [l] -> return l
         _   -> onlyOne "linker"

-#endif

 
     writeFile cProgName $
         concatMap outFlagHeaderCProg flags++
 
     writeFile cProgName $
         concatMap outFlagHeaderCProg flags++

@@ -613,17 +607,17 @@ output flags name toks = do
         ++ [cProgName]
         ++ ["-o", oProgName]
        )
         ++ [cProgName]
         ++ ["-o", oProgName]
        )

-    removeFile cProgName
+    finallyRemove cProgName $ do

 
     rawSystemL ("linking " ++ oProgName) beVerbose linker
         (  [f | LinkFlag f <- flags]
         ++ [oProgName]
         ++ ["-o", progName]
        )
 
     rawSystemL ("linking " ++ oProgName) beVerbose linker
         (  [f | LinkFlag f <- flags]
         ++ [oProgName]
         ++ ["-o", progName]
        )

-    removeFile oProgName
+    finallyRemove oProgName $ do

 
     rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
 
     rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName

-    removeFile progName
+    finallyRemove progName $ do

 
     when needsH $ writeFile outHName $
         "#ifndef "++includeGuard++"\n" ++
 
     when needsH $ writeFile outHName $
         "#ifndef "++includeGuard++"\n" ++

@@ -675,6 +669,19 @@ rawSystemWithStdOutL action flg prog args outFile = do
     ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
     _             -> return ()
 
     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")
 
 onlyOne :: String -> IO a
 onlyOne what = die ("Only one "++what++" may be specified\n")
 

@@ -909,9 +916,7 @@ getExecDir cmd =
           removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
 
 getExecPath :: IO (Maybe String)
           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
 getExecPath =
      allocaArray len $ \buf -> do
          ret <- getModuleFileName nullPtr buf len