X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FCodeOutput.lhs;h=d1b293353acc14ff3291fc867b16ce670c6219f0;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=a61e0472349a391ce01971656be75723f0e4ecda;hpb=3019b95e6e9c12694966d8b187b3b18c99e821ff;p=ghc-hetmet.git diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index a61e047..d1b2933 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -4,110 +4,300 @@ \section{Code output phase} \begin{code} -module CodeOutput( codeOutput ) where +module CodeOutput( codeOutput, outputForeignStubs ) where #include "HsVersions.h" #ifndef OMIT_NATIVE_CODEGEN +import UniqSupply ( mkSplitUniqSupply ) import AsmCodeGen ( nativeCodeGen ) #endif + #ifdef ILX import IlxGen ( ilxGen ) #endif -import TyCon ( TyCon ) -import Id ( Id ) -import Class ( Class ) -import StgSyn ( StgBinding ) -import AbsCSyn ( AbstractC, absCNop ) -import PprAbsC ( dumpRealC, writeRealC ) -import UniqSupply ( UniqSupply ) -import Module ( Module, moduleString ) -import CmdLineOpts -import Maybes ( maybeToBool ) -import ErrUtils ( doIfSet, dumpIfSet ) +#ifdef JAVA +import JavaGen ( javaGen ) +import qualified PrintJava +import OccurAnal ( occurAnalyseBinds ) +#endif + +import Finder ( mkStubPaths ) +import PprC ( writeCs ) +import CmmLint ( cmmLint ) +import Packages +import Util +import FastString ( unpackFS ) +import Cmm ( Cmm ) +import HscTypes +import DynFlags +import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable -import IO ( IOMode(..), hPutStr, hClose, openFile ) +import Pretty ( Mode(..), printDoc ) +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} +%* * +%************************************************************************ \begin{code} -codeOutput :: Module - -> [TyCon] -> [Class] -- Local tycons and classes - -> [(StgBinding,[Id])] -- The STG program with SRTs - -> SDoc -- C stubs for foreign exported functions - -> SDoc -- Header file prototype for foreign exported functions - -> AbstractC -- Compiled abstract C - -> UniqSupply - -> IO () -codeOutput mod_name tycons classes stg_binds c_code h_code flat_abstractC ncg_uniqs - = -- You can have C (c_output) or assembly-language (ncg_output), +codeOutput :: DynFlags + -> Module + -> ModLocation + -> ForeignStubs + -> [PackageId] + -> [Cmm] -- Compiled C-- + -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-}) + +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] -#ifndef OMIT_NATIVE_CODEGEN - let - (stix_final, ncg_output_d) = nativeCodeGen flat_absC_ncg ncg_uniqs - ncg_output_w = (\ f -> printForAsm f ncg_output_d) - in - dumpIfSet opt_D_dump_stix "Final stix code" stix_final >> - dumpIfSet opt_D_dump_asm "Asm code" ncg_output_d >> - doOutput opt_ProduceS ncg_output_w >> + -- Dunno if the above comment is still meaningful now. JRS 001024. + + 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; #else + panic "Java support not compiled into this ghc"; +#endif + HscILX -> #ifdef ILX - doOutput opt_ProduceS (\f -> printForUser f (ilxGen tycons stg_binds)) >> + let tycons = typeEnvTyCons type_env in + outputIlx dflags filenm mod_name tycons stg_binds; +#else + panic "ILX support not compiled into this ghc"; #endif + } + ; return stubs_exist + } + +doOutput :: String -> (Handle -> IO ()) -> IO () +doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action +\end{code} + + +%************************************************************************ +%* * +\subsection{C} +%* * +%************************************************************************ + +\begin{code} +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 ("/* 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 mod location +\end{code} + + +%************************************************************************ +%* * +\subsection{Assembler} +%* * +%************************************************************************ + +\begin{code} +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 + where + +#else /* OMIT_NATIVE_CODEGEN */ + + = pprPanic "This compiler was built without a native code generator" + (text "Use -fvia-C instead") + #endif +\end{code} - dumpIfSet opt_D_dump_foreign "Foreign export header file" stub_h_output_d >> - outputForeignStubs True{-.h output-} opt_ProduceExportHStubs stub_h_output_w >> - dumpIfSet opt_D_dump_foreign "Foreign export stubs" stub_c_output_d >> - outputForeignStubs False{-not .h-} opt_ProduceExportCStubs stub_c_output_w >> +%************************************************************************ +%* * +\subsection{Java} +%* * +%************************************************************************ - dumpIfSet opt_D_dump_realC "Real C" c_output_d >> - doOutput opt_ProduceC c_output_w +\begin{code} +#ifdef JAVA +outputJava dflags filenm mod tycons core_binds + = doOutput filenm (\ f -> printForUser f alwaysQualify pp_java) + -- User style printing for now to keep indentation + where + occ_anal_binds = occurAnalyseBinds core_binds + -- Make sure we have up to date dead-var information + java_code = javaGen mod [{- Should be imports-}] tycons occ_anal_binds + pp_java = PrintJava.compilationUnit java_code +#endif +\end{code} + +%************************************************************************ +%* * +\subsection{Ilx} +%* * +%************************************************************************ + +\begin{code} +#ifdef ILX +outputIlx dflags filename mod tycons stg_binds + = doOutput filename (\ f -> printForC f pp_ilx) where - (flat_absC_c, flat_absC_ncg) = - case (maybeToBool opt_ProduceC || opt_D_dump_realC, - maybeToBool opt_ProduceS || opt_D_dump_asm) of - (True, False) -> (flat_abstractC, absCNop) - (False, True) -> (absCNop, flat_abstractC) - (False, False) -> (absCNop, absCNop) - (True, True) -> error "ERROR: Can't do both .hc and .s at the same time" - - -- 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 - - c_output_d = dumpRealC flat_absC_c - c_output_w = (\ f -> writeRealC f flat_absC_c) - - - -- 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 is_header switch "" = return () -outputForeignStubs is_header switch doc_str = - case switch of - Nothing -> return () - Just fname -> writeFile fname (include_prefix ++ doc_str) - where - include_prefix - | is_header = "#include \"Rts.h\"\n" - | otherwise = "#include \"RtsAPI.h\"\n" - -doOutput switch io_action - = case switch of - Nothing -> return () - Just fname -> - openFile fname WriteMode >>= \ handle -> - io_action handle >> - hClose handle + pp_ilx = ilxGen mod tycons stg_binds +#endif +\end{code} + + +%************************************************************************ +%* * +\subsection{Foreign import/export} +%* * +%************************************************************************ + +\begin{code} +outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs + -> IO (Bool, -- Header file created + Bool) -- C file created +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 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 + + stub_c_file_exists + <- outputForeignStubs_help stub_c stub_c_output_w + ("#define IN_STG_CODE 0\n" ++ + "#include \"Rts.h\"\n" ++ + rts_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 mod location + +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 fname doc_str header footer + = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n") + return True \end{code}