X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FCodeOutput.lhs;h=2d68b830ecfc6f5ffed74dee6cf31f987d4147b6;hb=0a5613f40b0e32cf59966e6b56b807cdbe80aa7b;hp=79305fcccb68c0af0011e84e08beb4dd4d82a184;hpb=ad94d40948668032189ad22a0ad741ac1f645f50;p=ghc-hetmet.git diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index 79305fc..2d68b83 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -4,13 +4,6 @@ \section{Code output phase} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings --- for details - module CodeOutput( codeOutput, outputForeignStubs ) where #include "HsVersions.h" @@ -30,24 +23,21 @@ import Finder ( mkStubPaths ) import PprC ( writeCs ) import CmmLint ( cmmLint ) import Packages -import PackageConfig ( rtsPackageId ) import Util -import FastString ( unpackFS ) import Cmm ( RawCmm ) import HscTypes import DynFlags import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable -import Pretty ( Mode(..), printDoc ) -import Module ( Module, ModLocation(..), moduleName ) -import List ( nub ) +import Module import Maybes ( firstJust ) -import Distribution.Package ( showPackageId ) -import Directory ( doesFileExist ) -import Monad ( when ) -import IO +import Control.Exception +import Control.Monad +import System.Directory +import System.FilePath +import System.IO \end{code} %************************************************************************ @@ -89,15 +79,14 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC ; 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; + HscC -> outputC dflags filenm flat_abstractC pkg_deps; HscJava -> #ifdef JAVA outputJava dflags filenm mod_name tycons core_binds; #else panic "Java support not compiled into this ghc"; #endif + HscNothing -> panic "codeOutput: HscNothing" } ; return stubs_exist } @@ -114,8 +103,13 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action %************************************************************************ \begin{code} -outputC dflags filenm mod location flat_absC - (stub_h_exists, _) packages foreign_stubs +outputC :: DynFlags + -> FilePath + -> [RawCmm] + -> [PackageId] + -> IO () + +outputC dflags filenm flat_absC packages = do -- figure out which header files to #include in the generated .hc file: -- @@ -123,38 +117,22 @@ outputC dflags filenm mod location flat_absC -- * -#include options from the cmdline and OPTIONS pragmas -- * the _stub.h file, if there is one. -- - pkg_configs <- getPreloadPackagesAnd 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 rts = getPackageDetails (pkgState dflags) rtsPackageId - let cc_injects = unlines (map mk_include all_headers) + let cc_injects = unlines (map mk_include (includes rts)) mk_include h_file = case h_file of '"':_{-"-} -> "#include "++h_file '<':_ -> "#include "++h_file _ -> "#include \""++h_file++"\"" + pkg_configs <- getPreloadPackagesAnd dflags packages + let pkg_names = map (display.sourcePackageId) pkg_configs + doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") hPutStr h cc_injects - when stub_h_exists $ - hPutStrLn h ("#include \"" ++ (filenameOf stub_h) ++ "\"") writeCs dflags h flat_absC - where - (_, stub_h) = mkStubPaths dflags (moduleName mod) location \end{code} @@ -165,10 +143,11 @@ outputC dflags filenm mod location flat_absC %************************************************************************ \begin{code} -outputAsm dflags filenm flat_absC +outputAsm :: DynFlags -> FilePath -> [RawCmm] -> IO () #ifndef OMIT_NATIVE_CODEGEN +outputAsm dflags filenm flat_absC = do ncg_uniqs <- mkSplitUniqSupply 'n' {-# SCC "OutputAsm" #-} doOutput filenm $ @@ -178,6 +157,7 @@ outputAsm dflags filenm flat_absC #else /* OMIT_NATIVE_CODEGEN */ +outputAsm _ _ _ = pprPanic "This compiler was built without a native code generator" (text "Use -fvia-C instead") @@ -216,15 +196,15 @@ outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs -> IO (Bool, -- Header file created Bool) -- C file created outputForeignStubs dflags mod location stubs - | NoStubs <- stubs = do + = case stubs of + NoStubs -> 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 + ForeignStubs h_code c_code -> do let stub_c_output_d = pprCode CStyle c_code stub_c_output_w = showSDoc stub_c_output_d @@ -234,7 +214,7 @@ outputForeignStubs dflags mod location stubs stub_h_output_w = showSDoc stub_h_output_d -- in - createDirectoryHierarchy (directoryOf stub_c) + createDirectoryHierarchy (takeDirectory stub_c) dumpIfSet_dyn dflags Opt_D_dump_foreign "Foreign export header file" stub_h_output_d @@ -265,15 +245,17 @@ outputForeignStubs dflags mod location stubs return (stub_h_file_exists, stub_c_file_exists) where - (stub_c, stub_h) = mkStubPaths dflags (moduleName mod) location + (stub_c, stub_h, _) = mkStubPaths dflags (moduleName mod) location + + cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n" + cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n" -cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n" -cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n" -- Don't use doOutput for dumping the f. export stubs -- since it is more than likely that the stubs file will -- turn out to be empty, in which case no file should be created. -outputForeignStubs_help fname "" header footer = return False +outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool +outputForeignStubs_help _fname "" _header _footer = return False outputForeignStubs_help fname doc_str header footer = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n") return True