Remove LazyUniqFM; fixes trac #3880

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

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 5ac10ec..c0aed96 100644 (file)
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -35,7 +35,7 @@ import Finder
 import HscTypes
 import Outputable
 import Module
-import LazyUniqFM              ( eltsUFM )
+import UniqFM          ( eltsUFM )
 import ErrUtils
 import DynFlags
 import StaticFlags     ( v_Ld_inputs, opt_Static, WayName(..) )
@@ -696,19 +696,30 @@ 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
        src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
-       (dflags, unhandled_flags, warns)
+       (dflags1, unhandled_flags, warns)
            <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
-       handleFlagWarnings dflags warns
        checkProcessArgsResult unhandled_flags
 
-       if not (dopt Opt_Cpp dflags) then
+       if not (dopt Opt_Cpp dflags1) then do
+           -- we have to be careful to emit warnings only once.
+           unless (dopt Opt_Pp dflags1) $ handleFlagWarnings dflags1 warns
+
            -- no need to preprocess CPP, just pass input file along
           -- to the next phase of the pipeline.
-          return (HsPp sf, dflags, maybe_loc, input_fn)
+           return (HsPp sf, dflags1, maybe_loc, input_fn)
        else do
-           output_fn <- liftIO $ get_output_fn dflags (HsPp sf) maybe_loc
-           liftIO $ doCpp dflags True{-raw-} False{-no CC opts-} input_fn output_fn
-           return (HsPp sf, dflags, maybe_loc, output_fn)
+           output_fn <- liftIO $ get_output_fn dflags1 (HsPp sf) maybe_loc
+           liftIO $ doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn
+            -- re-read the pragmas now that we've preprocessed the file
+            -- See #2464,#3457
+            src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
+            (dflags2, unhandled_flags, warns)
+                <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
+            unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns
+            -- the HsPp pass below will emit warnings
+            checkProcessArgsResult unhandled_flags
+
+           return (HsPp sf, dflags2, maybe_loc, output_fn)
 
 -------------------------------------------------------------------------------
 -- HsPp phase 
@@ -730,7 +741,15 @@ runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
                             ] ++
                             map SysTools.Option hspp_opts
                           )
-           return (Hsc sf, dflags, maybe_loc, output_fn)
+
+            -- re-read pragmas now that we've parsed the file (see #3674)
+            src_opts <- liftIO $ getOptionsFromFile dflags output_fn
+            (dflags1, unhandled_flags, warns)
+                <- liftIO $ parseDynamicNoPackageFlags dflags src_opts
+            handleFlagWarnings dflags1 warns
+            checkProcessArgsResult unhandled_flags
+
+           return (Hsc sf, dflags1, maybe_loc, output_fn)
 
 -----------------------------------------------------------------------------
 -- Hsc phase
@@ -1280,6 +1299,20 @@ wrapper_behaviour dflags mode dep_packages =
        putStrLn (unwords (map (packageIdString . packageConfigId) allpkg))
        return $ 'F':s ++ ';':(seperateBySemiColon (map (packageIdString . packageConfigId) allpkg))
 
+mkExtraCObj :: DynFlags -> [String] -> IO FilePath
+mkExtraCObj dflags xs
+ = do cFile <- newTempName dflags "c"
+      oFile <- newTempName dflags "o"
+      writeFile cFile $ unlines xs
+      let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId
+      SysTools.runCc dflags
+                     ([Option        "-c",
+                       FileOption "" cFile,
+                       Option        "-o",
+                       FileOption "" oFile] ++
+                      map (FileOption "-I") (includeDirs rtsDetails))
+      return oFile
+
 -- generates a Perl skript starting a parallel prg under PVM
 mk_pvm_wrapper_script :: String -> String -> String -> String
 mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
@@ -1390,6 +1423,20 @@ 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 []
+    rtsOptsObj <- case rtsOpts dflags of
+                  Just opts ->
+                      do fn <- mkExtraCObj dflags
+                                 -- We assume that the Haskell "show" does
+                                 -- the right thing here
+                                 ["char *ghc_rts_opts = " ++ show opts ++ ";"]
+                         return [fn]
+                  Nothing -> return []
 
     pkg_link_opts <- getPackageLinkOpts dflags dep_packages
 
@@ -1464,6 +1511,8 @@ linkBinary dflags o_files dep_packages = do
 #endif
                      ++ pkg_lib_path_opts
                       ++ main_lib
+                      ++ rtsEnabledObj
+                      ++ rtsOptsObj
                      ++ pkg_link_opts
 #ifdef darwin_TARGET_OS
                      ++ pkg_framework_path_opts
@@ -1682,6 +1731,14 @@ linkDynLib dflags o_files dep_packages = do
     -----------------------------------------------------------------------------
 
     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
+    let buildingRts = thisPackage dflags == rtsPackageId
+    let bsymbolicFlag = if buildingRts
+                        then -- -Bsymbolic breaks the way we implement
+                             -- hooks in the RTS
+                             []
+                        else -- we need symbolic linking to resolve
+                             -- non-PIC intra-package-relocations
+                             ["-Wl,-Bsymbolic"]
 
     SysTools.runLink dflags
         ([ SysTools.Option verb
@@ -1691,7 +1748,8 @@ linkDynLib dflags o_files dep_packages = do
         ++ map SysTools.Option (
            md_c_flags
         ++ o_files
-        ++ [ "-shared", "-Wl,-Bsymbolic" ] -- we need symbolic linking to resolve non-PIC intra-package-relocations
+        ++ [ "-shared" ]
+        ++ bsymbolicFlag
          ++ [ "-Wl,-soname," ++ takeFileName output_fn ] -- set the library soname
         ++ extra_ld_inputs
         ++ lib_path_opts