Make -rtsopts more flexible

[ghc-hetmet.git] / compiler / main / DriverPipeline.hs

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 2019836..2b9cd43 100644 (file)
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -581,7 +581,9 @@ pipeLoop hsc_env phase stop_phase
            " but I wanted to stop at phase " ++ show stop_phase)
 
   | otherwise
-  = do (next_phase, dflags', maybe_loc, output_fn)
+  = do liftIO $ debugTraceMsg (hsc_dflags hsc_env) 4
+                              (ptext (sLit "Running phase") <+> ppr phase)
+       (next_phase, dflags', maybe_loc, output_fn)
           <- runPhase phase stop_phase hsc_env orig_basename
                       orig_suff input_fn orig_get_output_fn maybe_loc
        let hsc_env' = hsc_env {hsc_dflags = dflags'}
@@ -1250,20 +1252,27 @@ runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
     let dflags  = hsc_dflags hsc_env
     let lo_opts = getOpts dflags opt_lo
     let opt_lvl = max 0 (min 2 $ optLevel dflags)
+    -- don't specify anything if user has specified commands. We do this for
+    -- opt but not llc since opt is very specifically for optimisation passes
+    -- only, so if the user is passing us extra options we assume they know
+    -- what they are doing and don't get in the way.
+    let optFlag = if null lo_opts
+                     then [SysTools.Option (llvmOpts !! opt_lvl)]
+                     else []
 
     output_fn <- get_output_fn dflags LlvmLlc maybe_loc
 
     SysTools.runLlvmOpt dflags
                ([ SysTools.FileOption "" input_fn,
-                    SysTools.Option (llvmOpts !! opt_lvl),
                     SysTools.Option "-o",
                     SysTools.FileOption "" output_fn]
-               ++ map SysTools.Option lo_opts)
+                ++ optFlag
+                ++ map SysTools.Option lo_opts)
 
     return (LlvmLlc, dflags, maybe_loc, output_fn)
   where 
-        -- we always run Opt since we rely on it to fix up some pretty
-        -- big deficiencies in the code we generate
+        -- we always (unless -optlo specified) run Opt since we rely on it to
+        -- fix up some pretty big deficiencies in the code we generate
         llvmOpts = ["-mem2reg", "-O1", "-O2"]
 
 
@@ -1504,12 +1513,16 @@ linkBinary dflags o_files dep_packages = do
     let no_hs_main = dopt Opt_NoHsMain dflags
     let main_lib | no_hs_main = []
                  | otherwise  = [ "-lHSrtsmain" ]
-    rtsEnabledObj <- if dopt Opt_RtsOptsEnabled dflags
-                     then do fn <- mkExtraCObj dflags
-                                    ["#include \"Rts.h\"",
-                                     "const rtsBool rtsOptsEnabled = rtsTrue;"]
-                             return [fn]
-                     else return []
+    let mkRtsEnabledObj val = do fn <- mkExtraCObj dflags
+                                           ["#include \"Rts.h\"",
+                                            "#include \"RtsOpts.h\"",
+                                            "const rtsOptsEnabledEnum rtsOptsEnabled = "
+                                                ++ val ++ ";"]
+                                 return [fn]
+    rtsEnabledObj <- case rtsOptsEnabled dflags of
+                     RtsOptsNone     -> mkRtsEnabledObj "rtsOptsNone"
+                     RtsOptsSafeOnly -> return []
+                     RtsOptsAll      -> mkRtsEnabledObj "rtsOptsAll"
     rtsOptsObj <- case rtsOpts dflags of
                   Just opts ->
                       do fn <- mkExtraCObj dflags