X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FCodeOutput.lhs;h=d6e130946c4bce494c60c96d9c80b7082a765fdb;hb=7eb5e29b4a7b6fef55512bc7bf3308e712ca3eba;hp=d1b293353acc14ff3291fc867b16ce670c6219f0;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index d1b2933..d6e1309 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -13,10 +13,6 @@ import UniqSupply ( mkSplitUniqSupply ) import AsmCodeGen ( nativeCodeGen ) #endif -#ifdef ILX -import IlxGen ( ilxGen ) -#endif - #ifdef JAVA import JavaGen ( javaGen ) import qualified PrintJava @@ -29,13 +25,13 @@ import CmmLint ( cmmLint ) import Packages import Util import FastString ( unpackFS ) -import Cmm ( Cmm ) +import Cmm ( RawCmm ) import HscTypes import DynFlags + import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable -import Pretty ( Mode(..), printDoc ) -import Module ( Module, ModLocation(..) ) +import Module import List ( nub ) import Maybes ( firstJust ) @@ -43,6 +39,7 @@ import Distribution.Package ( showPackageId ) import Directory ( doesFileExist ) import Monad ( when ) import IO +import System.FilePath \end{code} %************************************************************************ @@ -57,7 +54,7 @@ codeOutput :: DynFlags -> ModLocation -> ForeignStubs -> [PackageId] - -> [Cmm] -- Compiled C-- + -> [RawCmm] -- Compiled C-- -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-}) codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC @@ -93,13 +90,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC #else panic "Java support not compiled into this ghc"; #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"; -#endif + HscNothing -> panic "codeOutput: HscNothing" } ; return stubs_exist } @@ -116,6 +107,14 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action %************************************************************************ \begin{code} +outputC :: DynFlags + -> FilePath -> Module -> ModLocation + -> [RawCmm] + -> (Bool, Bool) + -> [PackageId] + -> ForeignStubs + -> IO () + outputC dflags filenm mod location flat_absC (stub_h_exists, _) packages foreign_stubs = do @@ -125,7 +124,7 @@ 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 <- getExplicitPackagesAnd dflags packages + pkg_configs <- getPreloadPackagesAnd dflags packages let pkg_names = map (showPackageId.package) pkg_configs c_includes <- getPackageCIncludes pkg_configs @@ -133,15 +132,15 @@ outputC dflags filenm mod location flat_absC ffi_decl_headers = case foreign_stubs of - NoStubs -> [] - ForeignStubs _ _ fdhs _ -> map unpackFS (nub fdhs) + 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 @@ -153,10 +152,10 @@ outputC dflags filenm mod location flat_absC hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") hPutStr h cc_injects when stub_h_exists $ - hPutStrLn h ("#include \"" ++ (filenameOf stub_h) ++ "\"") + hPutStrLn h ("#include \"" ++ inc_stub_h ++ "\"") writeCs dflags h flat_absC where - (_, stub_h) = mkStubPaths dflags mod location + (_, _, inc_stub_h) = mkStubPaths dflags (moduleName mod) location \end{code} @@ -167,16 +166,16 @@ outputC dflags filenm mod location flat_absC %************************************************************************ \begin{code} +outputAsm :: DynFlags -> FilePath -> [RawCmm] -> IO () outputAsm dflags filenm flat_absC #ifndef OMIT_NATIVE_CODEGEN = do ncg_uniqs <- mkSplitUniqSupply 'n' - 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 + + {-# SCC "OutputAsm" #-} doOutput filenm $ + \f -> {-# SCC "NativeCodeGen" #-} + nativeCodeGen dflags f ncg_uniqs flat_absC where #else /* OMIT_NATIVE_CODEGEN */ @@ -210,22 +209,6 @@ outputJava dflags filenm mod tycons core_binds %************************************************************************ %* * -\subsection{Ilx} -%* * -%************************************************************************ - -\begin{code} -#ifdef ILX -outputIlx dflags filename mod tycons stg_binds - = doOutput filename (\ f -> printForC f pp_ilx) - where - pp_ilx = ilxGen mod tycons stg_binds -#endif -\end{code} - - -%************************************************************************ -%* * \subsection{Foreign import/export} %* * %************************************************************************ @@ -235,15 +218,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 @@ -253,18 +236,15 @@ 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 -- 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 = [] + let rts_includes = + let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in + concatMap mk_include (includes rts_pkg) mk_include i = "#include \"" ++ i ++ "\"\n" stub_h_file_exists @@ -287,15 +267,17 @@ outputForeignStubs dflags mod location stubs return (stub_h_file_exists, stub_c_file_exists) where - (stub_c, stub_h) = mkStubPaths dflags 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