Make -rtsopts more flexible

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

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index a77aa7a..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'}
@@ -698,12 +700,12 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l
 
 runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
   = do let dflags0 = hsc_dflags hsc_env
-       let dflags0' = flattenLanguageFlags dflags0
+       let dflags0' = flattenExtensionFlags dflags0
        src_opts <- liftIO $ getOptionsFromFile dflags0' input_fn
        (dflags1, unhandled_flags, warns)
            <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
        checkProcessArgsResult unhandled_flags
-       let dflags1' = flattenLanguageFlags dflags1
+       let dflags1' = flattenExtensionFlags dflags1
 
        if not (dopt Opt_Cpp dflags1') then do
            -- we have to be careful to emit warnings only once.
@@ -720,7 +722,7 @@ runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
             src_opts <- liftIO $ getOptionsFromFile dflags0' output_fn
             (dflags2, unhandled_flags, warns)
                 <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
-            let dflags2' = flattenLanguageFlags dflags2
+            let dflags2' = flattenExtensionFlags dflags2
             unless (dopt Opt_Pp dflags2') $ handleFlagWarnings dflags2' warns
             -- the HsPp pass below will emit warnings
             checkProcessArgsResult unhandled_flags
@@ -732,7 +734,7 @@ runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 
 runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
   = do let dflags = hsc_dflags hsc_env
-           dflags' = flattenLanguageFlags dflags
+           dflags' = flattenExtensionFlags dflags
        if not (dopt Opt_Pp dflags) then
            -- no need to preprocess, just pass input file along
            -- to the next phase of the pipeline.
@@ -753,7 +755,7 @@ runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
             src_opts <- liftIO $ getOptionsFromFile dflags' output_fn
             (dflags1, unhandled_flags, warns)
                 <- liftIO $ parseDynamicNoPackageFlags dflags src_opts
-            let dflags1' = flattenLanguageFlags dflags1
+            let dflags1' = flattenExtensionFlags dflags1
             handleFlagWarnings dflags1' warns
             checkProcessArgsResult unhandled_flags
 
@@ -905,7 +907,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma
 runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
   = do
        let dflags = hsc_dflags hsc_env
-           dflags' = flattenLanguageFlags dflags
+           dflags' = flattenExtensionFlags dflags
        output_fn <- liftIO $ get_output_fn dflags' Cmm maybe_loc
        liftIO $ doCpp dflags' False{-not raw-} True{-include CC opts-} input_fn output_fn
        return (Cmm, dflags', maybe_loc, output_fn)
@@ -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