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
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
\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
; 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;
%************************************************************************
\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:
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}
%************************************************************************
\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
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 ++
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"
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
-> 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 []
-----------------------------------------------------------------------------
-- 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.
--
-- -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-}
= 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
let dflags' = dflags { hscTarget = hsc_lang,
hscOutName = output_fn,
- hscStubCOutName = basename ++ "_stub.c",
- hscStubHOutName = basename ++ "_stub.h",
extCoreName = basename ++ ".hcr" }
hsc_env <- newHscEnv dflags'
_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
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
(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
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
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
stgToDo = Nothing,
hscTarget = defaultHscTarget,
hscOutName = "",
- hscStubHOutName = "",
- hscStubCOutName = "",
extCoreName = "",
verbosity = 0,
optLevel = 0,
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 = [],
| 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.
, ( "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))
, ( "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))
mkHomeModLocation2, -- :: ModuleName -> FilePath -> String -> IO ModLocation
addHomeModuleToFinder, -- :: HscEnv -> Module -> ModLocation -> IO ()
uncacheModule, -- :: HscEnv -> Module -> IO ()
+ mkStubPaths,
findObjectLinkableMaybe,
findObjectLinkable,
import Util
import DynFlags ( DynFlags(..), isOneShot, GhcMode(..) )
import Outputable
+import Maybes ( expectJust )
import DATA_IOREF ( IORef, writeIORef, readIORef )
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,
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
-> 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
-- -----------------------------------------------------------------------------
+-- 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
-------------------
-- 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
-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,
------------------ 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
------------------ 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)
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
--
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
projects / ghc-hetmet.git / commitdiff