X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FCodeOutput.lhs;h=0148ca4343ab3547d040a959aea4aed146b5cc0b;hb=7f24ae51ed36c5c0308a2d0de23e243f32a0043c;hp=2b0d745ae3bcddea19ff9385be17f439ad2cc3b8;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 2b0d745..0148ca4 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -19,29 +19,32 @@ 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 Util import FastString ( unpackFS ) -import DriverState ( v_HCHeader ) -import Id ( Id ) -import StgSyn ( StgBinding ) -import AbsCSyn ( AbstractC ) -import PprAbsC ( dumpRealC, writeRealC ) -import HscTypes ( ModGuts(..), ModGuts, ForeignStubs(..), typeEnvTyCons ) -import CmdLineOpts -import ErrUtils ( dumpIfSet_dyn, showPass ) +import Cmm ( Cmm ) +import HscTypes +import DynFlags +import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable import Pretty ( Mode(..), printDoc ) -import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName ) -import DATA_IOREF ( readIORef, writeIORef ) +import Module ( Module, ModLocation(..) ) +import List ( nub ) +import Maybes ( firstJust ) + +import Distribution.Package ( showPackageId ) +import Directory ( doesFileExist ) import Monad ( when ) import IO \end{code} - %************************************************************************ %* * \subsection{Steering} @@ -50,48 +53,56 @@ import IO \begin{code} codeOutput :: DynFlags - -> ModGuts - -> [(StgBinding,[Id])] -- The STG program with SRTs - -> AbstractC -- Compiled abstract C + -> Module + -> ModLocation + -> ForeignStubs + -> [PackageId] + -> [Cmm] -- Compiled 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_binds = core_binds}) - stg_binds flat_abstractC - = let - tycons = typeEnvTyCons type_env - in + +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 -- flat_abstractC. WDP 94/10] -- Dunno if the above comment is still meaningful now. JRS 001024. - do { showPass dflags "CodeOutput" - ; let filenm = dopt_OutName dflags - ; stub_names <- outputForeignStubs dflags foreign_stubs - ; 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 + do { when (dopt Opt_DoCmmLinting dflags) $ do + { showPass dflags "CmmLint" + ; let lints = map cmmLint flat_abstractC + ; case firstJust lints of + Just err -> do { printDump err + ; ghcExit dflags 1 + } + Nothing -> return () + } + + ; showPass dflags "CodeOutput" + ; 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 this_mod location + flat_abstractC stubs_exist pkg_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 + HscNothing -> return (); + } + ; return stubs_exist } doOutput :: String -> (Handle -> IO ()) -> IO () @@ -106,14 +117,47 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action %************************************************************************ \begin{code} -outputC dflags filenm flat_absC (stub_h_exists, _) - = do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC) - header <- readIORef v_HCHeader +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: + -- + -- * extra_includes from packages + -- * -#include options from the cmdline and OPTIONS pragmas + -- * the _stub.h file, if there is one. + -- + 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 + + ffi_decl_headers + = case foreign_stubs of + 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 + '"':_{-"-} -> "#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 + hPutStrLn h ("#include \"" ++ (filenameOf stub_h) ++ "\"") + writeCs dflags h flat_absC + where + (_, stub_h) = mkStubPaths dflags mod location \end{code} @@ -129,9 +173,8 @@ outputAsm dflags filenm flat_absC #ifndef OMIT_NATIVE_CODEGEN = do ncg_uniqs <- mkSplitUniqSupply 'n' - let (stix_final, ncg_output_d) = _scc_ "NativeCodeGen" - nativeCodeGen flat_absC ncg_uniqs - dumpIfSet_dyn dflags Opt_D_dump_stix "Final stix code" stix_final + 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 @@ -189,41 +232,54 @@ outputIlx dflags filename mod tycons stg_binds %************************************************************************ \begin{code} - -- Turn the list of headers requested in foreign import - -- declarations into a string suitable for emission into generated - -- C code... -mkForeignHeaders headers - = unlines - . map (\fname -> "#include \"" ++ unpackFS fname ++ "\"") - . reverse - $ headers - -outputForeignStubs :: DynFlags -> ForeignStubs +outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs -> IO (Bool, -- Header file created Bool) -- C file created -outputForeignStubs dflags NoStubs = return (False, False) -outputForeignStubs dflags (ForeignStubs h_code c_code hdrs _) +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 + 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 - -- Extend the list of foreign headers (used in outputC) - fhdrs <- readIORef v_HCHeader - let new_fhdrs = fhdrs ++ mkForeignHeaders hdrs - writeIORef v_HCHeader new_fhdrs - 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" ++ - new_fhdrs ++ - "#include \"RtsAPI.h\"\n" ++ + "#include \"Rts.h\"\n" ++ + rts_includes ++ cplusplus_hdr) cplusplus_ftr -- We're adding the default hc_header to the stub file, but this @@ -232,13 +288,7 @@ outputForeignStubs dflags (ForeignStubs h_code c_code hdrs _) 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"