LLVM: Add in new LLVM mangler for implementing TNTC on OSX

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

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 7274f2a..046e21c 100644 (file)
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -48,6 +48,7 @@ import Maybes           ( expectJust )
 import ParserCoreUtils  ( getCoreModuleName )
 import SrcLoc
 import FastString
+import LlvmCodeGen      ( llvmFixupAsm )
 -- import MonadUtils
 
 -- import Data.Either
@@ -605,7 +606,7 @@ getOutputFilename stop_phase output basename
                 keep_hc    = dopt Opt_KeepHcFiles dflags
                 keep_raw_s = dopt Opt_KeepRawSFiles dflags
                 keep_s     = dopt Opt_KeepSFiles dflags
-               keep_bc    = dopt Opt_KeepLlvmFiles dflags
+                keep_bc    = dopt Opt_KeepLlvmFiles dflags
 
                 myPhaseInputExt HCc    = hcsuf
                 myPhaseInputExt StopLn = osuf
@@ -619,8 +620,7 @@ getOutputFilename stop_phase output basename
                              StopLn               -> True
                              Mangle  | keep_raw_s -> True
                              As      | keep_s     -> True
-                            LlvmAs  | keep_bc    -> True
-                            LlvmOpt | keep_bc    -> True
+                             LlvmOpt | keep_bc    -> True
                              HCc     | keep_hc    -> True
                              _other               -> False
 
@@ -1237,50 +1237,28 @@ runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc
 
 
 -----------------------------------------------------------------------------
--- LlvmAs phase
+-- LlvmOpt phase
 
-runPhase LlvmAs _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
+runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
   = liftIO $ do
-       let dflags  = hsc_dflags hsc_env
-       let la_opts = getOpts dflags opt_la
-
-       output_fn <- get_output_fn dflags LlvmOpt maybe_loc
-
-       SysTools.runLlvmAs dflags
-                      (map SysTools.Option la_opts
-                      ++ [ SysTools.FileOption "" input_fn,
-                           SysTools.Option "-o", SysTools.FileOption "" output_fn])
-
-       return (LlvmOpt, dflags, maybe_loc, output_fn)
+    let dflags  = hsc_dflags hsc_env
+    let lo_opts = getOpts dflags opt_lo
+    let opt_lvl = max 0 (min 2 $ optLevel dflags)
 
+    output_fn <- get_output_fn dflags LlvmLlc maybe_loc
 
------------------------------------------------------------------------------
--- LlvmOpt phase
+    SysTools.runLlvmOpt dflags
+               (map SysTools.Option lo_opts
+               ++ [ SysTools.FileOption "" input_fn,
+                    SysTools.Option (llvmOpts !! opt_lvl),
+                    SysTools.Option "-o",
+                    SysTools.FileOption "" output_fn])
 
-runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
-  = liftIO $ do
-       let dflags  = hsc_dflags hsc_env
-       let lo_opts = getOpts dflags opt_lo
-       let opt_lvl = max 0 (min 2 $ optLevel dflags)
-
-    -- only run if > 0 OR opt options given by user
-       if opt_lvl /= 0 || lo_opts /= []
-               then do
-                       output_fn <- get_output_fn dflags LlvmLlc maybe_loc
-
-                       SysTools.runLlvmOpt dflags
-                                      (map SysTools.Option lo_opts
-                                      ++ [ SysTools.FileOption "" input_fn,
-                                           SysTools.Option (llvmOpts !! opt_lvl),
-                                           SysTools.Option "-o",
-                                           SysTools.FileOption "" output_fn])
-
-                       return (LlvmLlc, dflags, maybe_loc, output_fn)
-
-               else
-                       return (LlvmLlc, dflags, maybe_loc, input_fn)
+    return (LlvmLlc, dflags, maybe_loc, output_fn)
   where 
-               llvmOpts = ["-O1", "-O2", "-O3"]
+        -- we always run Opt since we rely on it to fix up some pretty
+        -- big deficiencies in the code we generate
+        llvmOpts = ["-mem2reg", "-O1", "-O2"]
 
 
 -----------------------------------------------------------------------------
@@ -1288,22 +1266,38 @@ runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 
 runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
   = liftIO $ do
-       let dflags  = hsc_dflags hsc_env
-       let lc_opts = getOpts dflags opt_lc
-       let opt_lvl = max 0 (min 2 $ optLevel dflags)
+    let dflags  = hsc_dflags hsc_env
+    let lc_opts = getOpts dflags opt_lc
+    let opt_lvl = max 0 (min 2 $ optLevel dflags)
+#if darwin_TARGET_OS
+    let nphase = LlvmMangle
+#else
+    let nphase = As
+#endif
 
-       output_fn <- get_output_fn dflags As maybe_loc
+    output_fn <- get_output_fn dflags nphase maybe_loc
 
-       SysTools.runLlvmLlc dflags
-                      (map SysTools.Option lc_opts
-                      ++ [ -- SysTools.Option "-tailcallopt",
+    SysTools.runLlvmLlc dflags
+            (map SysTools.Option lc_opts
+                ++ [ -- SysTools.Option "-tailcallopt",
                     SysTools.Option (llvmOpts !! opt_lvl),
                     SysTools.FileOption "" input_fn,
-                           SysTools.Option "-o", SysTools.FileOption "" output_fn])
+                    SysTools.Option "-o", SysTools.FileOption "" output_fn])
 
-       return (As, dflags, maybe_loc, output_fn)
+    return (nphase, dflags, maybe_loc, output_fn)
   where
-               llvmOpts = ["", "-O2", "-O3"]
+        llvmOpts = ["-O1", "-O2", "-O3"]
+
+
+-----------------------------------------------------------------------------
+-- LlvmMangle phase
+
+runPhase LlvmMangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
+  = liftIO $ do
+    let dflags = hsc_dflags hsc_env
+    output_fn <- get_output_fn dflags As maybe_loc
+    llvmFixupAsm input_fn output_fn
+    return (As, dflags, maybe_loc, output_fn)
 
 
 -- warning suppression
@@ -1351,12 +1345,14 @@ runPhase_MoveBinary dflags input_fn dep_packages
                 let behaviour' = concatMap (\x -> if x=='\\' then "\\\\" else [x]) behaviour
                 renameFile input_fn wrapped_executable
                 let rtsDetails = (getPackageDetails (pkgState dflags) rtsPackageId);
+                    (md_c_flags, _) = machdepCCOpts dflags
                 SysTools.runCc dflags
                   ([ SysTools.FileOption "" ((head (libraryDirs rtsDetails)) ++ "/dyn-wrapper.c")
                    , SysTools.Option ("-DBEHAVIOUR=\"" ++ behaviour' ++ "\"")
                    , SysTools.Option "-o"
-                   , SysTools.FileOption "" input_fn
-                   ] ++ map (SysTools.FileOption "-I") (includeDirs rtsDetails))
+                   , SysTools.FileOption "" input_fn] ++
+                   map (SysTools.FileOption "-I") (includeDirs rtsDetails) ++
+                   map Option md_c_flags)
                 return True
           _ -> return True
     | otherwise = return True
@@ -1865,9 +1861,9 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do
     cpp_prog       ([SysTools.Option verb]
                     ++ map SysTools.Option include_paths
                     ++ map SysTools.Option hsSourceCppOpts
+                    ++ map SysTools.Option target_defs
                     ++ map SysTools.Option hscpp_opts
                     ++ map SysTools.Option cc_opts
-                    ++ map SysTools.Option target_defs
                     ++ [ SysTools.Option     "-x"
                        , SysTools.Option     "c"
                        , SysTools.Option     input_fn
@@ -1906,7 +1902,7 @@ hscNextPhase dflags _ hsc_lang =
         HscC -> HCc
         HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle
                | otherwise -> As
-        HscLlvm        -> LlvmAs
+        HscLlvm        -> LlvmOpt
         HscNothing     -> StopLn
         HscInterpreted -> StopLn
         _other         -> StopLn