[project @ 2003-08-19 22:03:04 by krc]

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

diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs
index c5b56f2..5e9e7e5 100644 (file)
--- a/ghc/compiler/main/CodeOutput.lhs
+++ b/ghc/compiler/main/CodeOutput.lhs
@@ -24,18 +24,20 @@ import qualified PrintJava
 import OccurAnal       ( occurAnalyseBinds )
 #endif
 
-import Packages                ( PackageConfig(name), packageNameString )
+import Packages
 import DriverState     ( getExplicitPackagesAnd, getPackageCIncludes )
 import FastString      ( unpackFS )
 import AbsCSyn         ( AbstractC )
 import PprAbsC         ( dumpRealC, writeRealC )
-import HscTypes                ( ModGuts(..), ModGuts, ForeignStubs(..), 
-                         typeEnvTyCons, Dependencies(..) )
+import HscTypes
 import CmdLineOpts
 import ErrUtils                ( dumpIfSet_dyn, showPass )
 import Outputable
 import Pretty          ( Mode(..), printDoc )
-import CmdLineOpts     ( DynFlags, HscLang(..), dopt_OutName )
+import Module          ( Module )
+import ListSetOps      ( removeDupsEq )
+
+import System.Directory ( doesFileExist )
 import Monad           ( when )
 import IO
 \end{code}
@@ -49,20 +51,14 @@ import IO
 
 \begin{code}
 codeOutput :: DynFlags
-          -> ModGuts
+          -> Module
+          -> ForeignStubs
+          -> Dependencies
           -> AbstractC                 -- Compiled abstract C
           -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
 
-codeOutput dflags 
-          (ModGuts {mg_module = mod_name,
-                    mg_types  = type_env,
-                    mg_foreign = foreign_stubs,
-                    mg_deps    = deps,
-                    mg_binds   = core_binds})
-          flat_abstractC
-  = let
-       tycons = typeEnvTyCons type_env
-    in
+codeOutput dflags this_mod foreign_stubs deps flat_abstractC
+  = 
     -- You can have C (c_output) or assembly-language (ncg_output),
     -- but not both.  [Allowing for both gives a space leak on
     -- flat_abstractC.  WDP 94/10]
@@ -85,6 +81,7 @@ codeOutput dflags
 #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";
@@ -106,7 +103,7 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
 
 \begin{code}
 outputC dflags filenm flat_absC 
-       (stub_h_exists, _) dependencies (ForeignStubs _ _ ffi_decl_headers _ ) 
+       (stub_h_exists, _) dependencies foreign_stubs
   = do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC)
 
        -- figure out which header files to #include in the generated .hc file:
@@ -122,10 +119,16 @@ outputC dflags filenm flat_absC
        c_includes <- getPackageCIncludes pkg_configs
        let cmdline_includes = cmdlineHcIncludes dflags -- -#include options
        
+          ffi_decl_headers 
+             = case foreign_stubs of
+                 NoStubs                 -> []
+                 ForeignStubs _ _ fdhs _ -> map unpackFS (fst (removeDupsEq fdhs))
+                       -- Remove duplicates, because distinct foreign import decls
+                       -- may cite the same #include.  Order doesn't matter.
+
            all_headers =  c_includes
                       ++ reverse cmdline_includes
-                      ++ reverse (map unpackFS ffi_decl_headers)
-                          -- reverse correct?
+                      ++ ffi_decl_headers
 
        let cc_injects = unlines (map mk_include all_headers)
                   mk_include h_file = 
@@ -218,12 +221,22 @@ outputIlx dflags filename mod tycons stg_binds
 outputForeignStubs :: DynFlags -> ForeignStubs
                   -> IO (Bool,         -- Header file created
                          Bool)         -- C file created
-outputForeignStubs dflags NoStubs = return (False, False)
+outputForeignStubs dflags NoStubs = do
+-- When compiling External Core files, may need to use stub files from a 
+-- previous compilation
+   hFileExists <- doesFileExist (hscStubHOutName dflags)
+   cFileExists <- doesFileExist (hscStubCOutName dflags)
+   return (hFileExists, cFileExists)
 outputForeignStubs dflags (ForeignStubs h_code c_code _ _)
   = do
        dumpIfSet_dyn dflags Opt_D_dump_foreign
                       "Foreign export header file" stub_h_output_d
 
+       -- we need the #includes from the rts package for the stub files
+       rts_pkgs <- getPackageDetails [rtsPackage]
+       let rts_includes = concatMap mk_include (concatMap c_includes rts_pkgs)
+           mk_include i = "#include \"" ++ i ++ "\"\n"
+
        stub_h_file_exists
            <- outputForeignStubs_help (hscStubHOutName dflags) stub_h_output_w
                ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
@@ -235,6 +248,7 @@ outputForeignStubs dflags (ForeignStubs h_code c_code _ _)
            <- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w
                ("#define IN_STG_CODE 0\n" ++ 
                 "#include \"RtsAPI.h\"\n" ++
+                rts_includes ++
                 cplusplus_hdr)
                 cplusplus_ftr
           -- We're adding the default hc_header to the stub file, but this