X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FCodeOutput.lhs;h=5e9e7e5befaf23e96e6584c1e9d2243ed0d48778;hb=5c15e80ba77d4e30a84578df95ad32e471b0ff8c;hp=15b9a9cc8c94c20d06766e4dcc4c2d76d50cc00e;hpb=ce9687a5f450014c5596b32de8e8a7b99b6389e8;p=ghc-hetmet.git diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 15b9a9c..5e9e7e5 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -19,26 +19,25 @@ import IlxGen ( ilxGen ) #ifdef JAVA import JavaGen ( javaGen ) +import OccurAnal ( occurAnalyseBinds ) import qualified PrintJava import OccurAnal ( occurAnalyseBinds ) #endif -import DriverState ( v_HCHeader ) -import TyCon ( TyCon ) -import Id ( Id ) -import CoreSyn ( CoreBind ) -import StgSyn ( StgBinding ) +import Packages +import DriverState ( getExplicitPackagesAnd, getPackageCIncludes ) +import FastString ( unpackFS ) import AbsCSyn ( AbstractC ) import PprAbsC ( dumpRealC, writeRealC ) -import Module ( Module ) +import HscTypes import CmdLineOpts import ErrUtils ( dumpIfSet_dyn, showPass ) import Outputable import Pretty ( Mode(..), printDoc ) -import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName ) - -import DATA_IOREF ( readIORef ) +import Module ( Module ) +import ListSetOps ( removeDupsEq ) +import System.Directory ( doesFileExist ) import Monad ( when ) import IO \end{code} @@ -53,16 +52,14 @@ import IO \begin{code} codeOutput :: DynFlags -> Module - -> [TyCon] -- Local tycons - -> [CoreBind] -- Core bindings - -> [(StgBinding,[Id])] -- The STG program with SRTs - -> SDoc -- C stubs for foreign exported functions - -> SDoc -- Header file prototype for foreign exported functions - -> AbstractC -- Compiled abstract C + -> ForeignStubs + -> Dependencies + -> AbstractC -- Compiled abstract C -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-}) -codeOutput dflags mod_name tycons core_binds stg_binds - c_code h_code flat_abstractC - = -- You can have C (c_output) or assembly-language (ncg_output), + +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] @@ -70,27 +67,27 @@ codeOutput dflags mod_name tycons core_binds stg_binds do { showPass dflags "CodeOutput" ; let filenm = dopt_OutName dflags - ; stub_names <- outputForeignStubs dflags c_code h_code - ; case dopt_HscLang dflags of - HscInterpreted -> return stub_names - HscAsm -> outputAsm dflags filenm flat_abstractC - >> return stub_names - HscC -> outputC dflags filenm flat_abstractC stub_names - >> return stub_names + ; stubs_exist <- outputForeignStubs dflags foreign_stubs + ; case dopt_HscLang dflags of { + HscInterpreted -> return (); + HscAsm -> outputAsm dflags filenm flat_abstractC; + HscC -> outputC dflags filenm flat_abstractC stubs_exist + deps foreign_stubs; HscJava -> #ifdef JAVA - outputJava dflags filenm mod_name tycons core_binds - >> return stub_names + outputJava dflags filenm mod_name tycons core_binds; #else - panic "Java support not compiled into this ghc" + panic "Java support not compiled into this ghc"; #endif HscILX -> #ifdef ILX - outputIlx dflags filenm mod_name tycons stg_binds - >> return stub_names + let tycons = typeEnvTyCons type_env in + outputIlx dflags filenm mod_name tycons stg_binds; #else - panic "ILX support not compiled into this ghc" + panic "ILX support not compiled into this ghc"; #endif + } + ; return stubs_exist } doOutput :: String -> (Handle -> IO ()) -> IO () @@ -105,11 +102,44 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action %************************************************************************ \begin{code} -outputC dflags filenm flat_absC (stub_h_exists, _) +outputC dflags filenm flat_absC + (stub_h_exists, _) dependencies foreign_stubs = do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC) - header <- readIORef v_HCHeader + + -- figure out which header files to #include in the generated .hc file: + -- + -- * extra_includes from packages + -- * -#include options from the cmdline and OPTIONS pragmas + -- * the _stub.h file, if there is one. + -- + let packages = dep_pkgs dependencies + pkg_configs <- getExplicitPackagesAnd packages + let pkg_names = map name pkg_configs + + 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 + ++ ffi_decl_headers + + let cc_injects = unlines (map mk_include all_headers) + mk_include h_file = + case h_file of + '"':_{-"-} -> "#include "++h_file + '<':_ -> "#include "++h_file + _ -> "#include \""++h_file++"\"" + doOutput filenm $ \ h -> do - hPutStr h header + hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") + hPutStr h cc_injects when stub_h_exists $ hPutStrLn h ("#include \"" ++ (hscStubHOutName dflags) ++ "\"") writeRealC h flat_absC @@ -188,11 +218,25 @@ outputIlx dflags filename mod tycons stg_binds %************************************************************************ \begin{code} -outputForeignStubs dflags c_code h_code +outputForeignStubs :: DynFlags -> ForeignStubs + -> IO (Bool, -- Header file created + Bool) -- C file created +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 @@ -200,16 +244,14 @@ outputForeignStubs dflags c_code h_code dumpIfSet_dyn dflags Opt_D_dump_foreign "Foreign export stubs" stub_c_output_d - hc_header <- readIORef v_HCHeader - stub_c_file_exists <- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w ("#define IN_STG_CODE 0\n" ++ - hc_header ++ "#include \"RtsAPI.h\"\n" ++ + rts_includes ++ cplusplus_hdr) cplusplus_ftr - -- we're adding the default hc_header to the stub file, but this + -- We're adding the default hc_header to the stub file, but this -- isn't really HC code, so we need to define IN_STG_CODE==0 to -- avoid the register variables etc. being enabled.