X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FCodeOutput.lhs;h=7cfc2e9be21fb6aee943736cecd71499c8910f5e;hp=06e1ee785f16a145961660ac1e3eb49dbd4ff0e1;hb=066b369de2c6f7da03c88206288dca29ab061b31;hpb=ee565d464248078a4f2d46f98667aa4fcdc56db4 diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index 06e1ee7..7cfc2e9 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -8,14 +8,10 @@ module CodeOutput( codeOutput, outputForeignStubs ) where #include "HsVersions.h" -#ifndef OMIT_NATIVE_CODEGEN -import UniqSupply ( mkSplitUniqSupply ) -import AsmCodeGen ( nativeCodeGen ) -#endif +import AsmCodeGen ( nativeCodeGen ) +import LlvmCodeGen ( llvmCodeGen ) -#ifdef ILX -import IlxGen ( ilxGen ) -#endif +import UniqSupply ( mkSplitUniqSupply ) #ifdef JAVA import JavaGen ( javaGen ) @@ -27,23 +23,23 @@ import Finder ( mkStubPaths ) import PprC ( writeCs ) import CmmLint ( cmmLint ) import Packages -import PackageConfig ( rtsPackageId ) import Util -import FastString ( unpackFS ) -import Cmm ( Cmm ) +import OldCmm ( RawCmm ) import HscTypes import DynFlags +import Config +import SysTools + import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable -import Pretty ( Mode(..), printDoc ) -import Module ( Module, ModLocation(..), moduleName ) -import List ( nub ) -import Maybes ( firstJust ) - -import Distribution.Package ( showPackageId ) -import Directory ( doesFileExist ) -import Monad ( when ) -import IO +import Module +import Maybes ( firstJusts ) + +import Control.Exception +import Control.Monad +import System.Directory +import System.FilePath +import System.IO \end{code} %************************************************************************ @@ -58,8 +54,8 @@ codeOutput :: DynFlags -> ModLocation -> ForeignStubs -> [PackageId] - -> [Cmm] -- Compiled C-- - -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-}) + -> [RawCmm] -- Compiled C-- + -> IO (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}) codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC = @@ -72,7 +68,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC do { when (dopt Opt_DoCmmLinting dflags) $ do { showPass dflags "CmmLint" ; let lints = map cmmLint flat_abstractC - ; case firstJust lints of + ; case firstJusts lints of Just err -> do { printDump err ; ghcExit dflags 1 } @@ -85,22 +81,15 @@ 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; + HscLlvm -> outputLlvm dflags filenm flat_abstractC; HscJava -> #ifdef JAVA outputJava dflags filenm mod_name tycons core_binds; #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 } @@ -117,8 +106,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: -- @@ -126,38 +120,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 cc_injects = unlines (map mk_include all_headers) + let rts = getPackageDetails (pkgState dflags) rtsPackageId + + 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} @@ -168,24 +146,32 @@ outputC dflags filenm mod location flat_absC %************************************************************************ \begin{code} +outputAsm :: DynFlags -> FilePath -> [RawCmm] -> IO () outputAsm dflags filenm flat_absC - -#ifndef OMIT_NATIVE_CODEGEN - + | cGhcWithNativeCodeGen == "YES" = 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 - where -#else /* OMIT_NATIVE_CODEGEN */ + {-# SCC "OutputAsm" #-} doOutput filenm $ + \f -> {-# SCC "NativeCodeGen" #-} + nativeCodeGen dflags f ncg_uniqs flat_absC + | otherwise = pprPanic "This compiler was built without a native code generator" - (text "Use -fvia-C instead") + (text "Use -fvia-C instead") +\end{code} -#endif + +%************************************************************************ +%* * +\subsection{LLVM} +%* * +%************************************************************************ + +\begin{code} +outputLlvm :: DynFlags -> FilePath -> [RawCmm] -> IO () +outputLlvm dflags filenm flat_absC + = do ncg_uniqs <- mkSplitUniqSupply 'n' + doOutput filenm $ \f -> llvmCodeGen dflags f ncg_uniqs flat_absC \end{code} @@ -211,22 +197,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} %* * %************************************************************************ @@ -234,18 +204,21 @@ outputIlx dflags filename mod tycons stg_binds \begin{code} outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs -> IO (Bool, -- Header file created - Bool) -- C file created + Maybe FilePath) -- C file created outputForeignStubs dflags mod location stubs - | NoStubs <- stubs = do + = do + let stub_h = mkStubPaths dflags (moduleName mod) location + stub_c <- newTempName dflags "c" + + 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) + stub_h_exists <- doesFileExist stub_h + return (stub_h_exists, Nothing) - | ForeignStubs h_code c_code _ _ <- stubs - = do - let + ForeignStubs h_code c_code -> do + let stub_c_output_d = pprCode CStyle c_code stub_c_output_w = showSDoc stub_c_output_d @@ -254,7 +227,7 @@ outputForeignStubs dflags mod location stubs stub_h_output_w = showSDoc stub_h_output_d -- in - createDirectoryHierarchy (directoryOf stub_c) + createDirectoryHierarchy (takeDirectory stub_h) dumpIfSet_dyn dflags Opt_D_dump_foreign "Foreign export header file" stub_h_output_d @@ -265,6 +238,10 @@ outputForeignStubs dflags mod location stubs concatMap mk_include (includes rts_pkg) mk_include i = "#include \"" ++ i ++ "\"\n" + -- wrapper code mentions the ffi_arg type, which comes from ffi.h + ffi_includes | cLibFFI = "#include \"ffi.h\"\n" + | otherwise = "" + stub_h_file_exists <- outputForeignStubs_help stub_h stub_h_output_w ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr @@ -277,23 +254,26 @@ outputForeignStubs dflags mod location stubs ("#define IN_STG_CODE 0\n" ++ "#include \"Rts.h\"\n" ++ rts_includes ++ + ffi_includes ++ cplusplus_hdr) cplusplus_ftr -- We're adding the default hc_header to the stub file, but this -- isn't really HC code, so we need to define IN_STG_CODE==0 to -- avoid the register variables etc. being enabled. - return (stub_h_file_exists, stub_c_file_exists) - where - (stub_c, stub_h) = mkStubPaths dflags (moduleName mod) location + return (stub_h_file_exists, if stub_c_file_exists + then Just stub_c + else Nothing ) + where + 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