Commit f2e730f3 authored by simonmar's avatar simonmar

[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.
parent 55495951
......@@ -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"
......
......@@ -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
......
......@@ -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))
......
......@@ -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
......@@ -402,6 +404,36 @@ mkHiPath dflags basename mod_basename
return (hi_basename `joinFileExt` hisuf)
-- -----------------------------------------------------------------------------
-- 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
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment