Remove (most of) the FiniteMap wrapper

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

diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index 3a6f9f2..1693aa0 100644 (file)
--- a/compiler/main/SysTools.lhs
+++ b/compiler/main/SysTools.lhs
@@ -18,6 +18,8 @@ module SysTools (
         runAs, runLink,          -- [Option] -> IO ()
         runMkDLL,
         runWindres,
+        runLlvmOpt,
+        runLlvmLlc,
 
         touch,                  -- String -> String -> IO ()
         copy,
@@ -43,7 +45,6 @@ import ErrUtils
 import Panic
 import Util
 import DynFlags
-import FiniteMap
 
 import Exception
 import Data.IORef
@@ -56,6 +57,7 @@ import System.IO.Error as IO
 import System.Directory
 import Data.Char
 import Data.List
+import qualified Data.Map as Map
 
 #ifndef mingw32_HOST_OS
 import qualified System.Posix.Internals
@@ -159,6 +161,7 @@ initSysTools mbMinusB dflags0
         ; let installed :: FilePath -> FilePath
               installed file = top_dir </> file
               installed_mingw_bin file = top_dir </> ".." </> "mingw" </> "bin" </> file
+              installed_perl_bin file = top_dir </> ".." </> "perl" </> file
 
         ; let pkgconfig_path = installed "package.conf.d"
               ghc_usage_msg_path  = installed "ghc-usage.txt"
@@ -184,7 +187,7 @@ initSysTools mbMinusB dflags0
                 | isWindowsHost = installed_mingw_bin "gcc"
                 | otherwise     = cGCC
               perl_path
-                | isWindowsHost = installed cGHC_PERL
+                | isWindowsHost = installed_perl_bin cGHC_PERL
                 | otherwise     = cGHC_PERL
               -- 'touch' is a GHC util for Windows
               touch_path
@@ -218,6 +221,10 @@ initSysTools mbMinusB dflags0
         ; let   as_prog  = gcc_prog
                 ld_prog  = gcc_prog
 
+        -- figure out llvm location. (TODO: Acutally implement).
+        ; let lc_prog = "llc"
+              lo_prog = "opt"
+
         ; return dflags1{
                         ghcUsagePath = ghc_usage_msg_path,
                         ghciUsagePath = ghci_usage_msg_path,
@@ -234,7 +241,9 @@ initSysTools mbMinusB dflags0
                         pgm_dll = (mkdll_prog,mkdll_args),
                         pgm_T   = touch_path,
                         pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
-                        pgm_windres = windres_path
+                        pgm_windres = windres_path,
+                        pgm_lo  = (lo_prog,[]),
+                        pgm_lc  = (lc_prog,[])
                         -- Hans: this isn't right in general, but you can
                         -- elaborate it in the same way as the others
                 }
@@ -380,6 +389,16 @@ runAs dflags args = do
   mb_env <- getGccEnv args1
   runSomethingFiltered dflags id "Assembler" p args1 mb_env
 
+runLlvmOpt :: DynFlags -> [Option] -> IO ()
+runLlvmOpt dflags args = do
+  let (p,args0) = pgm_lo dflags
+  runSomething dflags "LLVM Optimiser" p (args0++args)
+
+runLlvmLlc :: DynFlags -> [Option] -> IO ()
+runLlvmLlc dflags args = do
+  let (p,args0) = pgm_lc dflags
+  runSomething dflags "LLVM Compiler" p (args0++args)
+
 runLink :: DynFlags -> [Option] -> IO ()
 runLink dflags args = do
   let (p,args0) = pgm_l dflags
@@ -396,10 +415,24 @@ runMkDLL dflags args = do
 
 runWindres :: DynFlags -> [Option] -> IO ()
 runWindres dflags args = do
-  let (_gcc,gcc_args) = pgm_c dflags
-      windres        = pgm_windres dflags
+  let (gcc, gcc_args) = pgm_c dflags
+      windres = pgm_windres dflags
+      quote x = "\"" ++ x ++ "\""
+      args' = -- If windres.exe and gcc.exe are in a directory containing
+              -- spaces then windres fails to run gcc. We therefore need
+              -- to tell it what command to use...
+              Option ("--preprocessor=" ++
+                      unwords (map quote (gcc :
+                                          map showOpt gcc_args ++
+                                          ["-E", "-xc", "-DRC_INVOKED"])))
+              -- ...but if we do that then if windres calls popen then
+              -- it can't understand the quoting, so we have to use
+              -- --use-temp-file so that it interprets it correctly.
+              -- See #1828.
+            : Option "--use-temp-file"
+            : args
   mb_env <- getGccEnv gcc_args
-  runSomethingFiltered dflags id "Windres" windres args mb_env
+  runSomethingFiltered dflags id "Windres" windres args' mb_env
 
 touch :: DynFlags -> String -> String -> IO ()
 touch dflags purpose arg =
@@ -439,8 +472,8 @@ cleanTempDirs dflags
    = unless (dopt Opt_KeepTmpFiles dflags)
    $ do let ref = dirsToClean dflags
         ds <- readIORef ref
-        removeTmpDirs dflags (eltsFM ds)
-        writeIORef ref emptyFM
+        removeTmpDirs dflags (Map.elems ds)
+        writeIORef ref Map.empty
 
 cleanTempFiles :: DynFlags -> IO ()
 cleanTempFiles dflags
@@ -465,7 +498,7 @@ newTempName :: DynFlags -> Suffix -> IO FilePath
 newTempName dflags extn
   = do d <- getTempDir dflags
        x <- getProcessID
-       findTempName (d ++ "/ghc" ++ show x ++ "_") 0
+       findTempName (d </> "ghc" ++ show x ++ "_") 0
   where
     findTempName :: FilePath -> Integer -> IO FilePath
     findTempName prefix x
@@ -482,16 +515,16 @@ getTempDir :: DynFlags -> IO FilePath
 getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
   = do let ref = dirsToClean dflags
        mapping <- readIORef ref
-       case lookupFM mapping tmp_dir of
+       case Map.lookup tmp_dir mapping of
            Nothing ->
                do x <- getProcessID
-                  let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_"
+                  let prefix = tmp_dir </> "ghc" ++ show x ++ "_"
                   let
                       mkTempDir :: Integer -> IO FilePath
                       mkTempDir x
                        = let dirname = prefix ++ show x
                          in do createDirectory dirname
-                               let mapping' = addToFM mapping tmp_dir dirname
+                               let mapping' = Map.insert tmp_dir dirname mapping
                                writeIORef ref mapping'
                                debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname)
                                return dirname