From: simonmar Date: Fri, 28 Oct 2005 15:22:39 +0000 (+0000) Subject: [project @ 2005-10-28 15:22:39 by simonmar] X-Git-Tag: Initial_conversion_from_CVS_complete~103 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;ds=sidebyside;h=f2e730f34ab0134391c88fe58f9f9e94b736da91;p=ghc-hetmet.git [project @ 2005-10-28 15:22:39 by simonmar] Add -stubdir option to control location of generated stub files. Also do some clean up while I'm here - remove hscStubCOut/hscStubHOut from DynFlags, and add mkStubPaths :: DynFlags -> Module -> ModLocation -> (FilePath,FilePath) to Finder. (this seemed better than caching the stub paths in every ModLocation, because they are rarely needed and only present in home modules, and are easily calculated from other available information). -stubdir behaves in exactly the same way as -odir and -hidir. --- diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index ce12d0c..d1b2933 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -23,11 +23,11 @@ import qualified PrintJava import OccurAnal ( occurAnalyseBinds ) #endif -import Distribution.Package ( showPackageId ) +import Finder ( mkStubPaths ) import PprC ( writeCs ) import CmmLint ( cmmLint ) import Packages -import Util ( filenameOf ) +import Util import FastString ( unpackFS ) import Cmm ( Cmm ) import HscTypes @@ -35,10 +35,11 @@ import DynFlags import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable import Pretty ( Mode(..), printDoc ) -import Module ( Module ) +import Module ( Module, ModLocation(..) ) import List ( nub ) import Maybes ( firstJust ) +import Distribution.Package ( showPackageId ) import Directory ( doesFileExist ) import Monad ( when ) import IO @@ -53,12 +54,13 @@ import IO \begin{code} codeOutput :: DynFlags -> Module + -> ModLocation -> ForeignStubs -> [PackageId] -> [Cmm] -- Compiled C-- -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-}) -codeOutput dflags this_mod foreign_stubs pkg_deps flat_abstractC +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 @@ -78,12 +80,13 @@ codeOutput dflags this_mod foreign_stubs pkg_deps flat_abstractC ; showPass dflags "CodeOutput" ; let filenm = hscOutName dflags - ; stubs_exist <- outputForeignStubs dflags foreign_stubs + ; 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 flat_abstractC stubs_exist - pkg_deps foreign_stubs; + 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; @@ -113,7 +116,7 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action %************************************************************************ \begin{code} -outputC dflags filenm flat_absC +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: @@ -150,8 +153,10 @@ outputC dflags filenm flat_absC hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") hPutStr h cc_injects when stub_h_exists $ - hPutStrLn h ("#include \"" ++ (filenameOf (hscStubHOutName dflags)) ++ "\"") + hPutStrLn h ("#include \"" ++ (filenameOf stub_h) ++ "\"") writeCs dflags h flat_absC + where + (_, stub_h) = mkStubPaths dflags mod location \end{code} @@ -226,17 +231,30 @@ outputIlx dflags filename mod tycons stg_binds %************************************************************************ \begin{code} -outputForeignStubs :: DynFlags -> ForeignStubs +outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs -> IO (Bool, -- Header file created Bool) -- C file created -outputForeignStubs dflags NoStubs = do --- When compiling External Core files, may need to use stub files from a --- previous compilation - hFileExists <- doesFileExist (hscStubHOutName dflags) - cFileExists <- doesFileExist (hscStubCOutName dflags) - return (hFileExists, cFileExists) -outputForeignStubs dflags (ForeignStubs h_code c_code _ _) +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 @@ -250,14 +268,14 @@ outputForeignStubs dflags (ForeignStubs h_code c_code _ _) mk_include i = "#include \"" ++ i ++ "\"\n" stub_h_file_exists - <- outputForeignStubs_help (hscStubHOutName dflags) stub_h_output_w + <- 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 (hscStubCOutName dflags) stub_c_output_w + <- outputForeignStubs_help stub_c stub_c_output_w ("#define IN_STG_CODE 0\n" ++ "#include \"Rts.h\"\n" ++ rts_includes ++ @@ -269,13 +287,7 @@ outputForeignStubs dflags (ForeignStubs h_code c_code _ _) return (stub_h_file_exists, stub_c_file_exists) where - -- 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 + (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" diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index a8fa8ce..d045f0a 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -157,8 +157,6 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, - hscStubCOutName = basename ++ "_stub.c", - hscStubHOutName = basename ++ "_stub.h", extCoreName = basename ++ ".hcr" } -- -no-recomp should also work with --make @@ -192,7 +190,7 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do -> do stub_unlinked <- if stub_c_exists then do - stub_o <- compileStub dflags' object_filename + stub_o <- compileStub dflags' this_mod location return [ DotO stub_o ] else return [] @@ -235,8 +233,9 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do ----------------------------------------------------------------------------- -- stub .h and .c files (for foreign export support) --- The _stub.c file is derived from the haskell source file (but stored --- in hscStubCOutName in the dflags for some reason, probably historical). +-- The _stub.c file is derived from the haskell source file, possibly taking +-- into account the -stubdir option. +-- -- Consequently, we derive the _stub.o filename from the haskell object -- filename. -- @@ -250,12 +249,13 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do -- -odir obj, we would get obj/src/A_stub.o, which is wrong; we want -- obj/A_stub.o. -compileStub dflags object_filename = do - let (o_base, o_ext) = splitFilename object_filename +compileStub :: DynFlags -> Module -> ModLocation -> IO FilePath +compileStub dflags mod location = do + let (o_base, o_ext) = splitFilename (ml_obj_file location) stub_o = o_base ++ "_stub" `joinFileExt` o_ext -- compile the _stub.c file w/ gcc - let stub_c = hscStubCOutName dflags + let (stub_c,_) = mkStubPaths dflags mod location runPipeline StopLn dflags (stub_c,Nothing) (SpecificFile stub_o) Nothing{-no ModLocation-} @@ -509,7 +509,7 @@ getOutputFilename dflags stop_phase output basename = func where hcsuf = hcSuf dflags - odir = outputDir dflags + odir = objectDir dflags osuf = objectSuf dflags keep_hc = dopt Opt_KeepHcFiles dflags keep_raw_s = dopt Opt_KeepRawSFiles dflags @@ -742,8 +742,6 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, - hscStubCOutName = basename ++ "_stub.c", - hscStubHOutName = basename ++ "_stub.h", extCoreName = basename ++ ".hcr" } hsc_env <- newHscEnv dflags' @@ -774,7 +772,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma _maybe_interpreted_code -> do when stub_c_exists $ do - stub_o <- compileStub dflags' o_file + stub_o <- compileStub dflags' mod_name location4 consIORef v_Ld_inputs stub_o -- In the case of hs-boot files, generate a dummy .o-boot @@ -802,8 +800,6 @@ runPhase Cmm stop dflags basename suff input_fn get_output_fn maybe_loc let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, - hscStubCOutName = basename ++ "_stub.c", - hscStubHOutName = basename ++ "_stub.h", extCoreName = basename ++ ".hcr" } ok <- hscCmmFile dflags' input_fn @@ -969,7 +965,7 @@ runPhase SplitAs stop dflags basename _suff _input_fn get_output_fn maybe_loc (split_s_prefix, n) <- readIORef v_Split_info let real_odir - | Just d <- outputDir dflags = d + | Just d <- objectDir dflags = d | otherwise = basename ++ "_split" let assemble_file n diff --git a/ghc/compiler/main/DynFlags.hs b/ghc/compiler/main/DynFlags.hs index c6702b1..a7f02bf 100644 --- a/ghc/compiler/main/DynFlags.hs +++ b/ghc/compiler/main/DynFlags.hs @@ -194,8 +194,6 @@ data DynFlags = DynFlags { stgToDo :: Maybe [StgToDo], -- similarly hscTarget :: HscTarget, hscOutName :: String, -- name of the output file - hscStubHOutName :: String, -- name of the .stub_h output file - hscStubCOutName :: String, -- name of the .stub_c output file extCoreName :: String, -- name of the .core output file verbosity :: Int, -- verbosity level optLevel :: Int, -- optimisation level @@ -213,13 +211,17 @@ data DynFlags = DynFlags { rtsBuildTag :: String, -- the RTS "way" -- paths etc. - outputDir :: Maybe String, - outputFile :: Maybe String, - outputHi :: Maybe String, + objectDir :: Maybe String, + hiDir :: Maybe String, + stubDir :: Maybe String, + objectSuf :: String, hcSuf :: String, - hiDir :: Maybe String, hiSuf :: String, + + outputFile :: Maybe String, + outputHi :: Maybe String, + includePaths :: [String], libraryPaths :: [String], frameworkPaths :: [String], -- used on darwin only @@ -326,8 +328,6 @@ defaultDynFlags = stgToDo = Nothing, hscTarget = defaultHscTarget, hscOutName = "", - hscStubHOutName = "", - hscStubCOutName = "", extCoreName = "", verbosity = 0, optLevel = 0, @@ -343,13 +343,16 @@ defaultDynFlags = buildTag = panic "buildTag", rtsBuildTag = panic "rtsBuildTag", - outputDir = Nothing, - outputFile = Nothing, - outputHi = Nothing, + objectDir = Nothing, + hiDir = Nothing, + stubDir = Nothing, + objectSuf = phaseInputExt StopLn, hcSuf = phaseInputExt HCc, - hiDir = Nothing, hiSuf = "hi", + + outputFile = Nothing, + outputHi = Nothing, includePaths = [], libraryPaths = [], frameworkPaths = [], @@ -442,13 +445,16 @@ getVerbFlag dflags | verbosity dflags >= 3 = "-v" | otherwise = "" -setOutputDir f d = d{ outputDir = f} -setOutputFile f d = d{ outputFile = f} -setOutputHi f d = d{ outputHi = f} +setObjectDir f d = d{ objectDir = f} +setHiDir f d = d{ hiDir = f} +setStubDir f d = d{ stubDir = f} + setObjectSuf f d = d{ objectSuf = f} -setHcSuf f d = d{ hcSuf = f} setHiSuf f d = d{ hiSuf = f} -setHiDir f d = d{ hiDir = f} +setHcSuf f d = d{ hcSuf = f} + +setOutputFile f d = d{ outputFile = f} +setOutputHi f d = d{ outputHi = f} -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] -- Config.hs should really use Option. @@ -805,7 +811,7 @@ dynamic_flags = [ , ( "framework" , HasArg (upd . addCmdlineFramework) ) ------- Output Redirection ------------------------------------------ - , ( "odir" , HasArg (upd . setOutputDir . Just)) + , ( "odir" , HasArg (upd . setObjectDir . Just)) , ( "o" , SepArg (upd . setOutputFile . Just)) , ( "ohi" , HasArg (upd . setOutputHi . Just )) , ( "osuf" , HasArg (upd . setObjectSuf)) @@ -813,6 +819,7 @@ dynamic_flags = [ , ( "hisuf" , HasArg (upd . setHiSuf)) , ( "hidir" , HasArg (upd . setHiDir . Just)) , ( "tmpdir" , HasArg (upd . setTmpDir)) + , ( "stubdir" , HasArg (upd . setStubDir . Just)) ------- Keeping temporary files ------------------------------------- , ( "keep-hc-file" , AnySuffix (\_ -> setDynFlag Opt_KeepHcFiles)) diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index f8f51da..81dedb8 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -13,6 +13,7 @@ module Finder ( mkHomeModLocation2, -- :: ModuleName -> FilePath -> String -> IO ModLocation addHomeModuleToFinder, -- :: HscEnv -> Module -> ModLocation -> IO () uncacheModule, -- :: HscEnv -> Module -> IO () + mkStubPaths, findObjectLinkableMaybe, findObjectLinkable, @@ -30,6 +31,7 @@ import FastString import Util import DynFlags ( DynFlags(..), isOneShot, GhcMode(..) ) import Outputable +import Maybes ( expectJust ) import DATA_IOREF ( IORef, writeIORef, readIORef ) @@ -347,8 +349,8 @@ mkHomeModLocation2 :: DynFlags mkHomeModLocation2 dflags mod src_basename ext = do let mod_basename = dots_to_slashes (moduleUserString mod) - obj_fn <- mkObjPath dflags src_basename mod_basename - hi_fn <- mkHiPath dflags src_basename mod_basename + obj_fn <- mkObjPath dflags src_basename mod_basename + hi_fn <- mkHiPath dflags src_basename mod_basename return (ModLocation{ ml_hs_file = Just (src_basename `joinFileExt` ext), ml_hi_file = hi_fn, @@ -357,7 +359,7 @@ mkHomeModLocation2 dflags mod src_basename ext = do hiOnlyModLocation :: DynFlags -> FilePath -> String -> Suffix -> IO ModLocation hiOnlyModLocation dflags path basename hisuf = do let full_basename = path `joinFileName` basename - obj_fn <- mkObjPath dflags full_basename basename + obj_fn <- mkObjPath dflags full_basename basename return ModLocation{ ml_hs_file = Nothing, ml_hi_file = full_basename `joinFileExt` hisuf, -- Remove the .hi-boot suffix from @@ -376,7 +378,7 @@ mkObjPath -> IO FilePath mkObjPath dflags basename mod_basename = do let - odir = outputDir dflags + odir = objectDir dflags osuf = objectSuf dflags obj_basename | Just dir <- odir = dir `joinFileName` mod_basename @@ -403,6 +405,36 @@ mkHiPath dflags basename mod_basename -- ----------------------------------------------------------------------------- +-- Filenames of the stub files + +-- We don't have to store these in ModLocations, because they can be derived +-- from other available information, and they're only rarely needed. + +mkStubPaths + :: DynFlags + -> Module + -> ModLocation + -> (FilePath,FilePath) + +mkStubPaths dflags mod location + = let + stubdir = stubDir dflags + + mod_basename = dots_to_slashes (moduleUserString mod) + src_basename = basenameOf (expectJust "mkStubPaths" + (ml_hs_file location)) + + stub_basename0 + | Just dir <- stubdir = dir `joinFileName` mod_basename + | otherwise = src_basename + + stub_basename = stub_basename0 ++ "_stub" + in + (stub_basename `joinFileExt` "c", + stub_basename `joinFileExt` "h") + -- the _stub.o filename is derived from the ml_obj_file. + +-- ----------------------------------------------------------------------------- -- findLinkable isn't related to the other stuff in here, -- but there's no other obvious place for it diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 2586340..5fb8671 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -456,7 +456,7 @@ hscBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result) ------------------- -- CONVERT TO STG and COMPLETE CODE GENERATION ; (stub_h_exists, stub_c_exists, maybe_bcos) - <- hscCodeGen dflags cg_guts + <- hscCodeGen dflags (ms_location mod_summary) cg_guts -- And the answer is ... ; dumpIfaceStats hsc_env @@ -469,7 +469,7 @@ hscBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result) -hscCodeGen dflags +hscCodeGen dflags location CgGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. cg_module = this_mod, @@ -500,7 +500,7 @@ hscCodeGen dflags ------------------ Create f-x-dynamic C-side stuff --- (istub_h_exists, istub_c_exists) - <- outputForeignStubs dflags foreign_stubs + <- outputForeignStubs dflags this_mod location foreign_stubs return ( istub_h_exists, istub_c_exists, Just comp_bc ) #else @@ -521,7 +521,7 @@ hscCodeGen dflags ------------------ Code output ----------------------- (stub_h_exists, stub_c_exists) - <- codeOutput dflags this_mod foreign_stubs + <- codeOutput dflags this_mod location foreign_stubs dependencies abstractC return (stub_h_exists, stub_c_exists, Nothing) @@ -534,10 +534,11 @@ hscCmmFile dflags filename = do case maybe_cmm of Nothing -> return False Just cmm -> do - codeOutput dflags no_mod NoStubs [] [cmm] + codeOutput dflags no_mod no_loc NoStubs [] [cmm] return True where no_mod = panic "hscCmmFile: no_mod" + no_loc = panic "hscCmmFile: no_location" myParseModule dflags src_filename maybe_src_buf diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index a9c4122..95891f7 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -240,7 +240,7 @@ checkOptions cli_mode dflags srcs objs = do -- verifyOutputFiles :: DynFlags -> IO () verifyOutputFiles dflags = do - let odir = outputDir dflags + let odir = objectDir dflags when (isJust odir) $ do let dir = fromJust odir flg <- doesDirectoryExist dir