X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FCodeOutput.lhs;h=0148ca4343ab3547d040a959aea4aed146b5cc0b;hb=7f24ae51ed36c5c0308a2d0de23e243f32a0043c;hp=7732497a648dcc82296ef2be9fa17c8c5cea6e7a;hpb=423d477bfecd490de1449c59325c8776f91d7aac;p=ghc-hetmet.git diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 7732497..0148ca4 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -19,28 +19,28 @@ import IlxGen ( ilxGen ) #ifdef JAVA import JavaGen ( javaGen ) -import OccurAnal ( occurAnalyseBinds ) import qualified PrintJava import OccurAnal ( occurAnalyseBinds ) #endif +import Finder ( mkStubPaths ) import PprC ( writeCs ) import CmmLint ( cmmLint ) import Packages -import DriverState ( getExplicitPackagesAnd, getPackageCIncludes ) +import Util import FastString ( unpackFS ) import Cmm ( Cmm ) import HscTypes -import CmdLineOpts +import DynFlags import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable import Pretty ( Mode(..), printDoc ) -import Module ( Module ) -import ListSetOps ( removeDupsEq ) +import Module ( Module, ModLocation(..) ) +import List ( nub ) import Maybes ( firstJust ) +import Distribution.Package ( showPackageId ) import Directory ( doesFileExist ) -import Data.List ( intersperse ) import Monad ( when ) import IO \end{code} @@ -54,12 +54,13 @@ import IO \begin{code} codeOutput :: DynFlags -> Module + -> ModLocation -> ForeignStubs - -> Dependencies + -> [PackageId] -> [Cmm] -- Compiled C-- -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-}) -codeOutput dflags this_mod foreign_stubs deps flat_abstractC +codeOutput dflags this_mod location foreign_stubs pkg_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 @@ -72,19 +73,20 @@ codeOutput dflags this_mod foreign_stubs deps flat_abstractC ; let lints = map cmmLint flat_abstractC ; case firstJust lints of Just err -> do { printDump err - ; ghcExit 1 + ; ghcExit dflags 1 } Nothing -> return () } ; showPass dflags "CodeOutput" - ; let filenm = dopt_OutName dflags - ; stubs_exist <- outputForeignStubs dflags foreign_stubs - ; case dopt_HscLang dflags of { + ; let filenm = hscOutName dflags + ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs + ; case hscTarget dflags of { HscInterpreted -> return (); HscAsm -> outputAsm dflags filenm flat_abstractC; - HscC -> outputC dflags filenm flat_abstractC stubs_exist - deps foreign_stubs; + HscC -> outputC dflags filenm this_mod location + flat_abstractC stubs_exist pkg_deps + foreign_stubs; HscJava -> #ifdef JAVA outputJava dflags filenm mod_name tycons core_binds; @@ -98,6 +100,7 @@ codeOutput dflags this_mod foreign_stubs deps flat_abstractC #else panic "ILX support not compiled into this ghc"; #endif + HscNothing -> return (); } ; return stubs_exist } @@ -114,8 +117,8 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action %************************************************************************ \begin{code} -outputC dflags filenm flat_absC - (stub_h_exists, _) dependencies foreign_stubs +outputC dflags filenm mod location flat_absC + (stub_h_exists, _) packages foreign_stubs = do -- figure out which header files to #include in the generated .hc file: -- @@ -123,9 +126,8 @@ outputC dflags filenm flat_absC -- * -#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 + pkg_configs <- getExplicitPackagesAnd dflags packages + let pkg_names = map (showPackageId.package) pkg_configs c_includes <- getPackageCIncludes pkg_configs let cmdline_includes = cmdlineHcIncludes dflags -- -#include options @@ -133,7 +135,7 @@ outputC dflags filenm flat_absC ffi_decl_headers = case foreign_stubs of NoStubs -> [] - ForeignStubs _ _ fdhs _ -> map unpackFS (fst (removeDupsEq fdhs)) + ForeignStubs _ _ fdhs _ -> map unpackFS (nub fdhs) -- Remove duplicates, because distinct foreign import decls -- may cite the same #include. Order doesn't matter. @@ -152,8 +154,10 @@ outputC dflags filenm flat_absC hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") hPutStr h cc_injects when stub_h_exists $ - hPutStrLn h ("#include \"" ++ (hscStubHOutName dflags) ++ "\"") - writeCs h flat_absC + hPutStrLn h ("#include \"" ++ (filenameOf stub_h) ++ "\"") + writeCs dflags h flat_absC + where + (_, stub_h) = mkStubPaths dflags mod location \end{code} @@ -228,34 +232,51 @@ outputIlx dflags filename mod tycons stg_binds %************************************************************************ \begin{code} -outputForeignStubs :: DynFlags -> ForeignStubs +outputForeignStubs :: DynFlags -> Module -> ModLocation -> 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 _ _) +outputForeignStubs dflags mod location stubs + | NoStubs <- stubs = do + -- When compiling External Core files, may need to use stub + -- files from a previous compilation + stub_c_exists <- doesFileExist stub_c + stub_h_exists <- doesFileExist stub_h + return (stub_h_exists, stub_c_exists) + + | ForeignStubs h_code c_code _ _ <- stubs = do + let + stub_c_output_d = pprCode CStyle c_code + stub_c_output_w = showSDoc stub_c_output_d + + -- Header file protos for "foreign export"ed functions. + stub_h_output_d = pprCode CStyle h_code + stub_h_output_w = showSDoc stub_h_output_d + -- in + + createDirectoryHierarchy (directoryOf stub_c) + 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) + 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 = [] mk_include i = "#include \"" ++ i ++ "\"\n" stub_h_file_exists - <- outputForeignStubs_help (hscStubHOutName dflags) stub_h_output_w + <- outputForeignStubs_help stub_h stub_h_output_w ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr dumpIfSet_dyn dflags Opt_D_dump_foreign "Foreign export stubs" stub_c_output_d stub_c_file_exists - <- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w + <- outputForeignStubs_help stub_c stub_c_output_w ("#define IN_STG_CODE 0\n" ++ "#include \"Rts.h\"\n" ++ rts_includes ++ @@ -267,13 +288,7 @@ outputForeignStubs dflags (ForeignStubs h_code c_code _ _) return (stub_h_file_exists, stub_c_file_exists) where - -- C stubs for "foreign export"ed functions. - stub_c_output_d = pprCode CStyle c_code - stub_c_output_w = showSDoc stub_c_output_d - - -- Header file protos for "foreign export"ed functions. - stub_h_output_d = pprCode CStyle h_code - stub_h_output_w = showSDoc stub_h_output_d + (stub_c, stub_h) = mkStubPaths dflags mod location cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n" cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"