X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FCodeOutput.lhs;h=ce12d0cc0ca48a947792cf74092a28cf1074f8b0;hb=78b72ed1e0ffab668e0d4bb31657942970515e4f;hp=3a3e4bbf1789cd3601fd384878ac619d3f1f49d4;hpb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;p=ghc-hetmet.git diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 3a3e4bb..ce12d0c 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -19,7 +19,6 @@ import IlxGen ( ilxGen ) #ifdef JAVA import JavaGen ( javaGen ) -import OccurAnal ( occurAnalyseBinds ) import qualified PrintJava import OccurAnal ( occurAnalyseBinds ) #endif @@ -28,16 +27,16 @@ import Distribution.Package ( showPackageId ) import PprC ( writeCs ) import CmmLint ( cmmLint ) import Packages -import DriverUtil ( filenameOf ) +import Util ( filenameOf ) import FastString ( unpackFS ) import Cmm ( Cmm ) import HscTypes -import CmdLineOpts +import DynFlags import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable import Pretty ( Mode(..), printDoc ) import Module ( Module ) -import ListSetOps ( removeDupsEq ) +import List ( nub ) import Maybes ( firstJust ) import Directory ( doesFileExist ) @@ -55,11 +54,11 @@ import IO codeOutput :: DynFlags -> Module -> ForeignStubs - -> Dependencies + -> [PackageId] -> [Cmm] -- Compiled C-- -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-}) -codeOutput dflags this_mod foreign_stubs deps flat_abstractC +codeOutput dflags this_mod 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 @@ -72,19 +71,19 @@ codeOutput dflags this_mod foreign_stubs deps flat_abstractC ; let lints = map cmmLint flat_abstractC ; case firstJust lints of Just err -> do { printDump err - ; ghcExit 1 + ; ghcExit dflags 1 } Nothing -> return () } ; showPass dflags "CodeOutput" - ; let filenm = dopt_OutName dflags + ; let filenm = hscOutName dflags ; stubs_exist <- outputForeignStubs dflags foreign_stubs - ; case dopt_HscLang dflags of { + ; case hscTarget dflags of { HscInterpreted -> return (); HscAsm -> outputAsm dflags filenm flat_abstractC; HscC -> outputC dflags filenm flat_abstractC stubs_exist - deps foreign_stubs; + pkg_deps foreign_stubs; HscJava -> #ifdef JAVA outputJava dflags filenm mod_name tycons core_binds; @@ -115,7 +114,7 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action \begin{code} outputC dflags filenm flat_absC - (stub_h_exists, _) dependencies foreign_stubs + (stub_h_exists, _) packages foreign_stubs = do -- figure out which header files to #include in the generated .hc file: -- @@ -123,7 +122,6 @@ outputC dflags filenm flat_absC -- * -#include options from the cmdline and OPTIONS pragmas -- * the _stub.h file, if there is one. -- - let packages = dep_pkgs dependencies pkg_configs <- getExplicitPackagesAnd dflags packages let pkg_names = map (showPackageId.package) pkg_configs @@ -133,7 +131,7 @@ outputC dflags filenm flat_absC ffi_decl_headers = case foreign_stubs of NoStubs -> [] - ForeignStubs _ _ fdhs _ -> map unpackFS (fst (removeDupsEq fdhs)) + ForeignStubs _ _ fdhs _ -> map unpackFS (nub fdhs) -- Remove duplicates, because distinct foreign import decls -- may cite the same #include. Order doesn't matter. @@ -153,7 +151,7 @@ outputC dflags filenm flat_absC hPutStr h cc_injects when stub_h_exists $ hPutStrLn h ("#include \"" ++ (filenameOf (hscStubHOutName dflags)) ++ "\"") - writeCs h flat_absC + writeCs dflags h flat_absC \end{code} @@ -245,7 +243,7 @@ outputForeignStubs dflags (ForeignStubs h_code c_code _ _) -- we need the #includes from the rts package for the stub files let rtsid = rtsPackageId (pkgState dflags) rts_includes - | Just pid <- rtsid = + | ExtPackage pid <- rtsid = let rts_pkg = getPackageDetails (pkgState dflags) pid in concatMap mk_include (includes rts_pkg) | otherwise = []