X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FCodeOutput.lhs;h=7732497a648dcc82296ef2be9fa17c8c5cea6e7a;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=c5b56f228dc94c71b704ccb1c25ab8c8e5118eee;hpb=854ab9a44c4f9a9cb6239bb0af14c150b0e454c6;p=ghc-hetmet.git diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index c5b56f2..7732497 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -24,23 +24,27 @@ import qualified PrintJava import OccurAnal ( occurAnalyseBinds ) #endif -import Packages ( PackageConfig(name), packageNameString ) +import PprC ( writeCs ) +import CmmLint ( cmmLint ) +import Packages import DriverState ( getExplicitPackagesAnd, getPackageCIncludes ) import FastString ( unpackFS ) -import AbsCSyn ( AbstractC ) -import PprAbsC ( dumpRealC, writeRealC ) -import HscTypes ( ModGuts(..), ModGuts, ForeignStubs(..), - typeEnvTyCons, Dependencies(..) ) +import Cmm ( Cmm ) +import HscTypes import CmdLineOpts -import ErrUtils ( dumpIfSet_dyn, showPass ) +import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable import Pretty ( Mode(..), printDoc ) -import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName ) +import Module ( Module ) +import ListSetOps ( removeDupsEq ) +import Maybes ( firstJust ) + +import Directory ( doesFileExist ) +import Data.List ( intersperse ) import Monad ( when ) import IO \end{code} - %************************************************************************ %* * \subsection{Steering} @@ -49,27 +53,31 @@ import IO \begin{code} codeOutput :: DynFlags - -> ModGuts - -> AbstractC -- Compiled abstract C + -> Module + -> ForeignStubs + -> Dependencies + -> [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_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] -- Dunno if the above comment is still meaningful now. JRS 001024. - do { showPass dflags "CodeOutput" + 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 1 + } + Nothing -> return () + } + + ; showPass dflags "CodeOutput" ; let filenm = dopt_OutName dflags ; stubs_exist <- outputForeignStubs dflags foreign_stubs ; case dopt_HscLang dflags of { @@ -85,6 +93,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,9 +115,8 @@ 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 _ ) - = do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC) - + (stub_h_exists, _) dependencies foreign_stubs + = do -- figure out which header files to #include in the generated .hc file: -- -- * extra_includes from packages @@ -122,10 +130,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 = @@ -139,7 +153,7 @@ outputC dflags filenm flat_absC hPutStr h cc_injects when stub_h_exists $ hPutStrLn h ("#include \"" ++ (hscStubHOutName dflags) ++ "\"") - writeRealC h flat_absC + writeCs h flat_absC \end{code} @@ -155,9 +169,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 @@ -218,12 +231,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 @@ -234,7 +257,8 @@ outputForeignStubs dflags (ForeignStubs h_code c_code _ _) stub_c_file_exists <- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w ("#define IN_STG_CODE 0\n" ++ - "#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