merge GHC HEAD

[ghc-hetmet.git] / compiler / main / SysTools.lhs

diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index 656ece1..9c086cc 100644 (file)
--- a/compiler/main/SysTools.lhs
+++ b/compiler/main/SysTools.lhs
@@ -181,7 +181,10 @@ initSysTools mbMinusB
         -- with the settings file, but it would be a little fiddly
         -- to make that possible, so for now you can't.
         ; gcc_prog <- if isWindowsHost then return $ installed_mingw_bin "gcc"
-                                       else getSetting "GCC command"
+                                       else getSetting "C compiler command"
+        ; gcc_args_str <- if isWindowsHost then return []
+                                           else getSetting "C compiler flags"
+        ; let gcc_args = map Option (words gcc_args_str)
         ; perl_path <- if isWindowsHost
                        then return $ installed_perl_bin "perl"
                        else getSetting "perl command"
@@ -224,14 +227,18 @@ initSysTools mbMinusB
         -- cpp is derived from gcc on all platforms
         -- HACK, see setPgmP below. We keep 'words' here to remember to fix
         -- Config.hs one day.
-        ; let cpp_path  = (gcc_prog,
-                           (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
+        ; let cpp_prog  = gcc_prog
+              cpp_args  = Option "-E"
+                        : map Option (words cRAWCPP_FLAGS)
+                       ++ gcc_args
 
         -- Other things being equal, as and ld are simply gcc
         ; let   as_prog  = gcc_prog
+                as_args  = gcc_args
                 ld_prog  = gcc_prog
+                ld_args  = gcc_args
 
-        -- figure out llvm location. (TODO: Acutally implement).
+        -- We just assume on command line
         ; let lc_prog = "llc"
               lo_prog = "opt"
 
@@ -244,12 +251,12 @@ initSysTools mbMinusB
                         sExtraGccViaCFlags = words myExtraGccViaCFlags,
                         sSystemPackageConfig = pkgconfig_path,
                         sPgm_L   = unlit_path,
-                        sPgm_P   = cpp_path,
+                        sPgm_P   = (cpp_prog, cpp_args),
                         sPgm_F   = "",
-                        sPgm_c   = (gcc_prog,[]),
+                        sPgm_c   = (gcc_prog, gcc_args),
                         sPgm_s   = (split_prog,split_args),
-                        sPgm_a   = (as_prog,[]),
-                        sPgm_l   = (ld_prog,[]),
+                        sPgm_a   = (as_prog, as_args),
+                        sPgm_l   = (ld_prog, ld_args),
                         sPgm_dll = (mkdll_prog,mkdll_args),
                         sPgm_T   = touch_path,
                         sPgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
@@ -781,20 +788,16 @@ data BuildMessage
   | EOF
 
 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
--- a) trace the command (at two levels of verbosity)
--- b) don't do it at all if dry-run is set
+-- trace the command (at two levels of verbosity)
 traceCmd dflags phase_name cmd_line action
  = do   { let verb = verbosity dflags
         ; showPass dflags phase_name
         ; debugTraceMsg dflags 3 (text cmd_line)
         ; hFlush stderr
 
-           -- Test for -n flag
-        ; unless (dopt Opt_DryRun dflags) $ do {
-
            -- And run it!
         ; action `catchIO` handle_exn verb
-        }}
+        }
   where
     handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
                               ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
@@ -815,14 +818,15 @@ getBaseDir :: IO (Maybe String)
 #if defined(mingw32_HOST_OS)
 -- Assuming we are running ghc, accessed by path  $(stuff)/bin/ghc.exe,
 -- return the path $(stuff)/lib.
-getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
-                buf <- mallocArray len
-                ret <- getModuleFileName nullPtr buf len
-                if ret == 0 then free buf >> return Nothing
-                            else do s <- peekCString buf
-                                    free buf
-                                    return (Just (rootDir s))
+getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
   where
+    try_size size = allocaArray (fromIntegral size) $ \buf -> do
+        ret <- c_GetModuleFileName nullPtr buf size
+        case ret of
+          0 -> return Nothing
+          _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf
+            | otherwise  -> try_size (size * 2)
+    
     rootDir s = case splitFileName $ normalise s of
                 (d, ghc_exe)
                  | lower ghc_exe `elem` ["ghc.exe",
@@ -837,8 +841,8 @@ getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
         where fail = panic ("can't decompose ghc.exe path: " ++ show s)
               lower = map toLower
 
-foreign import stdcall unsafe "GetModuleFileNameA"
-  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+  c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
 #else
 getBaseDir = return Nothing
 #endif