refactoring only: use the parameterised InstalledPackageInfo

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

diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index d1b2933..6d11c65 100644 (file)
--- a/compiler/main/CodeOutput.lhs
+++ b/compiler/main/CodeOutput.lhs
@@ -4,6 +4,13 @@
 \section{Code output phase}
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module CodeOutput( codeOutput, outputForeignStubs ) where
 
 #include "HsVersions.h"
@@ -13,10 +20,6 @@ import UniqSupply    ( mkSplitUniqSupply )
 import AsmCodeGen      ( nativeCodeGen )
 #endif
 
-#ifdef ILX
-import IlxGen          ( ilxGen )
-#endif
-
 #ifdef JAVA
 import JavaGen         ( javaGen )
 import qualified PrintJava
@@ -29,13 +32,14 @@ import CmmLint              ( cmmLint )
 import Packages
 import Util
 import FastString      ( unpackFS )
-import Cmm             ( Cmm )
+import Cmm             ( RawCmm )
 import HscTypes
 import DynFlags
+
 import ErrUtils                ( dumpIfSet_dyn, showPass, ghcExit )
 import Outputable
 import Pretty          ( Mode(..), printDoc )
-import Module          ( Module, ModLocation(..) )
+import Module
 import List            ( nub )
 import Maybes          ( firstJust )
 
@@ -57,7 +61,7 @@ codeOutput :: DynFlags
           -> ModLocation
           -> ForeignStubs
           -> [PackageId]
-          -> [Cmm]                     -- Compiled C--
+          -> [RawCmm]                  -- Compiled C--
           -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
 
 codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
@@ -93,13 +97,6 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
 #else
                                panic "Java support not compiled into this ghc";
 #endif
-            HscILX         -> 
-#ifdef ILX
-                              let tycons = typeEnvTyCons type_env in
-                              outputIlx dflags filenm mod_name tycons stg_binds;
-#else
-                               panic "ILX support not compiled into this ghc";
-#endif
          }
        ; return stubs_exist
        }
@@ -125,7 +122,7 @@ outputC dflags filenm mod location flat_absC
        --   * -#include options from the cmdline and OPTIONS pragmas
        --   * the _stub.h file, if there is one.
        --
-       pkg_configs <- getExplicitPackagesAnd dflags packages
+       pkg_configs <- getPreloadPackagesAnd dflags packages
        let pkg_names = map (showPackageId.package) pkg_configs
 
        c_includes <- getPackageCIncludes pkg_configs
@@ -133,15 +130,15 @@ outputC dflags filenm mod location flat_absC
        
           ffi_decl_headers 
              = case foreign_stubs of
-                 NoStubs                 -> []
-                 ForeignStubs _ _ fdhs _ -> map unpackFS (nub fdhs)
+                 NoStubs               -> []
+                 ForeignStubs _ _ fdhs -> map unpackFS (nub fdhs)
                        -- Remove duplicates, because distinct foreign import decls
                        -- may cite the same #include.  Order doesn't matter.
 
            all_headers =  c_includes
                       ++ reverse cmdline_includes
                       ++ ffi_decl_headers
-
+                       
        let cc_injects = unlines (map mk_include all_headers)
                   mk_include h_file = 
                    case h_file of 
@@ -153,10 +150,10 @@ outputC dflags filenm mod location flat_absC
          hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
          hPutStr h cc_injects
          when stub_h_exists $ 
-            hPutStrLn h ("#include \"" ++ (filenameOf stub_h) ++ "\"")
+            hPutStrLn h ("#include \"" ++ inc_stub_h ++ "\"")
          writeCs dflags h flat_absC
   where
-    (_, stub_h) = mkStubPaths dflags mod location
+    (_, _, inc_stub_h) = mkStubPaths dflags (moduleName mod) location
 \end{code}
 
 
@@ -172,11 +169,10 @@ outputAsm dflags filenm flat_absC
 #ifndef OMIT_NATIVE_CODEGEN
 
   = do ncg_uniqs <- mkSplitUniqSupply 'n'
-       ncg_output_d <- _scc_ "NativeCodeGen" 
-                         nativeCodeGen dflags flat_absC ncg_uniqs
-       dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" (docToSDoc ncg_output_d)
-       _scc_ "OutputAsm" doOutput filenm $
-          \f -> printDoc LeftMode f ncg_output_d
+
+       {-# SCC "OutputAsm" #-} doOutput filenm $
+          \f -> {-# SCC "NativeCodeGen" #-}
+                nativeCodeGen dflags f ncg_uniqs flat_absC
   where
 
 #else /* OMIT_NATIVE_CODEGEN */
@@ -210,22 +206,6 @@ outputJava dflags filenm mod tycons core_binds
 
 %************************************************************************
 %*                                                                     *
-\subsection{Ilx}
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
-#ifdef ILX
-outputIlx dflags filename mod tycons stg_binds
-  =  doOutput filename (\ f -> printForC f pp_ilx)
-  where
-    pp_ilx = ilxGen mod tycons stg_binds
-#endif
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
 \subsection{Foreign import/export}
 %*                                                                     *
 %************************************************************************
@@ -242,7 +222,7 @@ outputForeignStubs dflags mod location stubs
        stub_h_exists <- doesFileExist stub_h
        return (stub_h_exists, stub_c_exists)
 
-  | ForeignStubs h_code c_code _ _ <- stubs
+  | ForeignStubs h_code c_code _ <- stubs
   = do
        let
            stub_c_output_d = pprCode CStyle c_code
@@ -259,12 +239,9 @@ outputForeignStubs dflags mod location stubs
                       "Foreign export header file" stub_h_output_d
 
        -- we need the #includes from the rts package for the stub files
-       let rtsid = rtsPackageId (pkgState dflags)
-           rts_includes 
-               | ExtPackage pid <- rtsid = 
-                       let rts_pkg = getPackageDetails (pkgState dflags) pid in
-                       concatMap mk_include (includes rts_pkg)
-               | otherwise = []
+       let rts_includes = 
+              let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in
+              concatMap mk_include (includes rts_pkg)
            mk_include i = "#include \"" ++ i ++ "\"\n"
 
        stub_h_file_exists
@@ -287,7 +264,7 @@ outputForeignStubs dflags mod location stubs
 
         return (stub_h_file_exists, stub_c_file_exists)
   where
-   (stub_c, stub_h) = mkStubPaths dflags mod location
+   (stub_c, stub_h, _) = mkStubPaths dflags (moduleName mod) location
 
 cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
 cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"