diff options
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/Driver/Backpack.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Config/Finder.hs | 9 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Main.hs | 18 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Make.hs | 28 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 19 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Pipeline/Execute.hs | 89 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Pipeline/Monad.hs | 40 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 32 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Load.hs | 20 | ||||
| -rw-r--r-- | compiler/GHC/Linker/Dynamic.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Linker/Loader.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Linker/Static.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Unit/Finder.hs | 130 | ||||
| -rw-r--r-- | compiler/GHC/Unit/Finder/Types.hs | 34 | ||||
| -rw-r--r-- | compiler/GHC/Unit/Module/Graph.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Unit/Module/Location.hs | 27 | ||||
| -rw-r--r-- | compiler/GHC/Unit/Module/ModSummary.hs | 4 |
17 files changed, 272 insertions, 196 deletions
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index b966a08884..c4594329eb 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -757,8 +757,8 @@ summariseRequirement pn mod_name = do let fopts = initFinderOpts dflags let PackageName pn_fs = pn - location <- liftIO $ mkHomeModLocation2 fopts mod_name - (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig" + let location = mkHomeModLocation2 fopts mod_name + (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig" env <- getBkpEnv src_hash <- liftIO $ getFileHash (bkp_filename env) @@ -848,7 +848,7 @@ hsModuleToModSummary pn hsc_src modname -- To add insult to injury, we don't even actually use -- these filenames to figure out where the hi files go. -- A travesty! - location0 <- liftIO $ mkHomeModLocation2 fopts modname + let location0 = mkHomeModLocation2 fopts modname (unpackFS unit_fs </> moduleNameSlashes modname) (case hsc_src of diff --git a/compiler/GHC/Driver/Config/Finder.hs b/compiler/GHC/Driver/Config/Finder.hs index 4fa4278c09..3d830fc6d2 100644 --- a/compiler/GHC/Driver/Config/Finder.hs +++ b/compiler/GHC/Driver/Config/Finder.hs @@ -6,7 +6,8 @@ module GHC.Driver.Config.Finder ( import GHC.Prelude import GHC.Driver.Session -import GHC.Unit.Finder +import GHC.Unit.Finder.Types + -- | Create a new 'FinderOpts' from DynFlags. initFinderOpts :: DynFlags -> FinderOpts @@ -19,8 +20,10 @@ initFinderOpts flags = FinderOpts , finder_hieDir = hieDir flags , finder_hieSuf = hieSuf flags , finder_hiDir = hiDir flags - , finder_hiSuf = hiSuf flags + , finder_hiSuf = hiSuf_ flags + , finder_dynHiSuf = dynHiSuf_ flags , finder_objectDir = objectDir flags - , finder_objectSuf = objectSuf flags + , finder_objectSuf = objectSuf_ flags + , finder_dynObjectSuf = dynObjectSuf_ flags , finder_stubDir = stubDir flags } diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 9aeb04e336..1d36a83445 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -962,18 +962,8 @@ hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do Interpreter -> False _ -> True - -- mod_location only contains the base name, so we rebuild the - -- correct file extension from the dynflags. - baseName = ml_hi_file mod_location - buildIfName suffix is_dynamic - | Just name <- (if is_dynamic then dynOutputHi else outputHi) dflags - = name - | otherwise - = let with_hi = replaceExtension baseName suffix - in addBootSuffix_maybe (mi_boot iface) with_hi - write_iface dflags' iface = - let !iface_name = buildIfName (hiSuf dflags') (dynamicNow dflags') + let !iface_name = if dynamicNow dflags' then ml_dyn_hi_file mod_location else ml_hi_file mod_location profile = targetProfile dflags' in {-# SCC "writeIface" #-} @@ -1714,6 +1704,8 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do no_loc = ModLocation{ ml_hs_file = Just filename, ml_hi_file = panic "hscCompileCmmFile: no hi file", ml_obj_file = panic "hscCompileCmmFile: no obj file", + ml_dyn_obj_file = panic "hscCompileCmmFile: no dyn obj file", + ml_dyn_hi_file = panic "hscCompileCmmFile: no dyn obj file", ml_hie_file = panic "hscCompileCmmFile: no hie file"} -------------------- Stuff for new code gen --------------------- @@ -1945,6 +1937,8 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing, ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file", ml_obj_file = panic "hsDeclsWithLocation:ml_obj_file", + ml_dyn_obj_file = panic "hsDeclsWithLocation:ml_dyn_obj_file", + ml_dyn_hi_file = panic "hsDeclsWithLocation:ml_dyn_hi_file", ml_hie_file = panic "hsDeclsWithLocation:ml_hie_file" } ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv @@ -2155,6 +2149,8 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr ; let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing, ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file", ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file", + ml_dyn_obj_file = panic "hscCompileCoreExpr': ml_obj_file", + ml_dyn_hi_file = panic "hscCompileCoreExpr': ml_dyn_hi_file", ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" } ; let ictxt = hsc_IC hsc_env diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index fa1348bfe1..ba611db424 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -597,7 +597,7 @@ load' cache how_much mHscMessage mod_graph = do -- called Main, or (b) the user said -no-hs-main, indicating -- that main() is going to come from somewhere else. -- - let ofile = outputFile dflags + let ofile = outputFile_ dflags let no_hs_main = gopt Opt_NoHsMain dflags let main_mod = mainModIs hsc_env @@ -1652,27 +1652,26 @@ enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife bcknd tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf let dyn_tn = tn -<.> dynsuf addFilesToClean tmpfs dynLife [dyn_tn] - return tn + return (tn, dyn_tn) -- We don't want to create .o or .hi files unless we have been asked -- to by the user. But we need them, so we patch their locations in -- the ModSummary with temporary files. -- - (hi_file, o_file) <- + ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <- -- If ``-fwrite-interface` is specified, then the .o and .hi files -- are written into `-odir` and `-hidir` respectively. #16670 if gopt Opt_WriteInterface dflags - then return (ml_hi_file ms_location, ml_obj_file ms_location) + then return ((ml_hi_file ms_location, ml_dyn_hi_file ms_location) + , (ml_obj_file ms_location, ml_dyn_obj_file ms_location)) else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags)) <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags)) let ms' = ms { ms_location = - ms_location {ml_hi_file = hi_file, ml_obj_file = o_file} - , ms_hspp_opts = updOptLevel 0 $ - setOutputFile (Just o_file) $ - setDynOutputFile (Just $ dynamicOutputFile dflags o_file) $ - setOutputHi (Just hi_file) $ - setDynOutputHi (Just $ dynamicOutputHi dflags hi_file) $ - dflags {backend = bcknd} + ms_location { ml_hi_file = hi_file + , ml_obj_file = o_file + , ml_dyn_hi_file = dyn_hi_file + , ml_dyn_obj_file = dyn_o_file } + , ms_hspp_opts = updOptLevel 0 $ dflags {backend = bcknd} } pure (ExtendedModSummary ms' bkp_deps) | otherwise = return (ExtendedModSummary ms bkp_deps) @@ -1789,7 +1788,7 @@ summariseFile hsc_env old_summaries src_fn mb_phase maybe_buf let fopts = initFinderOpts (hsc_dflags hsc_env) -- Make a ModLocation for this file - location <- liftIO $ mkHomeModLocation fopts pi_mod_name src_fn + let location = mkHomeModLocation fopts pi_mod_name src_fn -- Tell the Finder cache where it is, so that subsequent calls -- to findModule will find it, even if it's not on any search path @@ -1904,7 +1903,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) | otherwise = find_it where dflags = hsc_dflags hsc_env - fopts = initFinderOpts dflags + fopts = initFinderOpts dflags home_unit = hsc_home_unit hsc_env fc = hsc_FC hsc_env units = hsc_units hsc_env @@ -1995,9 +1994,8 @@ data MakeNewModSummary makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ExtendedModSummary makeNewModSummary hsc_env MakeNewModSummary{..} = do let PreprocessedImports{..} = nms_preimps - let dflags = hsc_dflags hsc_env obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location) - dyn_obj_timestamp <- modificationTimeIfExists (dynamicOutputFile dflags (ml_obj_file nms_location)) + dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file nms_location) hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location) hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location) diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 1255cc3df3..59cb28eccc 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -433,7 +433,7 @@ link' logger tmpfs dflags unit_env batch_attempt_linking hpt let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked) obj_files = concatMap getOfiles linkables platform = targetPlatform dflags - exe_file = exeFileName platform staticLink (outputFile dflags) + exe_file = exeFileName platform staticLink (outputFile_ dflags) linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps @@ -470,7 +470,7 @@ linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do -- linking (unless the -fforce-recomp flag was given). let platform = ue_platform unit_env unit_state = ue_units unit_env - exe_file = exeFileName platform staticLink (outputFile dflags) + exe_file = exeFileName platform staticLink (outputFile_ dflags) e_exe_time <- tryIO $ getModificationUTCTime exe_file case e_exe_time of Left _ -> return True @@ -757,9 +757,12 @@ checkDynamicToo hsc_env dyn_too_rerun res = do -- | Enable dynamic-too, reset EPS resetHscEnv :: HscEnv -> IO HscEnv resetHscEnv hsc_env = do - let dflags0 = flip gopt_unset Opt_BuildDynamicToo - $ setDynamicNow - $ (hsc_dflags hsc_env) + let init_dflags = hsc_dflags hsc_env + dflags0 = flip gopt_unset Opt_BuildDynamicToo + $ setDynamicNow -- -dynamic + $ (init_dflags { hiSuf_ = dynHiSuf_ init_dflags -- -hisuf = -dynhisuf + , objectSuf_ = dynObjectSuf_ init_dflags -- -osuf = -dynosuf + }) hsc_env' <- newHscEnv dflags0 (dbs,unit_state,home_unit,mconstants) <- initUnits (hsc_logger hsc_env) dflags0 Nothing dflags1 <- updatePlatformConstants dflags0 mconstants @@ -814,11 +817,7 @@ hscGenBackendPipeline :: P m hscGenBackendPipeline pipe_env hsc_env mod_sum result = do let mod_name = moduleName (ms_mod mod_sum) src_flavour = (ms_hsc_src mod_sum) - dflags = hsc_dflags hsc_env - -- MP: The ModLocation is recalculated here to get the right paths when - -- -dynamic-too is enabled. `ModLocation` should be extended with a field for - -- the location of the `dyn_o` file to avoid this recalculation. - location <- liftIO (getLocation pipe_env dflags src_flavour mod_name) + let location = ms_location mod_sum (fos, miface, mlinkable, o_file) <- use (T_HscBackend pipe_env hsc_env mod_name src_flavour location result) final_fp <- hscPostBackendPipeline pipe_env hsc_env (ms_hsc_src mod_sum) (backend (hsc_dflags hsc_env)) (Just location) o_file final_linkable <- diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs index 370fde59a8..fcc6372509 100644 --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -81,6 +81,7 @@ import Data.Version import GHC.Utils.Panic import GHC.Unit.Module.Env import GHC.Driver.Env.KnotVars +import GHC.Driver.Config.Finder newtype HookedUse a = HookedUse { runHookedUse :: (Hooks, PhaseHook) -> IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch) via (ReaderT (Hooks, PhaseHook) IO) @@ -494,7 +495,7 @@ runHscBackendPhase :: PipeEnv runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env - o_file = ml_obj_file location -- The real object file + o_file = if dynamicNow dflags then ml_dyn_obj_file location else ml_obj_file location -- The real object file next_phase = hscPostBackendPhase src_flavour (backend dflags) case result of HscUpdate iface -> @@ -649,11 +650,11 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do -- (If we're linking then the -o applies to the linked thing, not to -- the object file for one module.) -- Note the nasty duplication with the same computation in compileFile above - location <- getLocation pipe_env dflags src_flavour mod_name + location <- mkOneShotModLocation pipe_env dflags src_flavour mod_name let o_file = ml_obj_file location -- The real object file hi_file = ml_hi_file location hie_file = ml_hie_file location - dyn_o_file = dynamicOutputFile dflags o_file + dyn_o_file = ml_dyn_obj_file location src_hash <- getFileHash (basename <.> suff) hi_date <- modificationTimeIfExists hi_file @@ -702,6 +703,52 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do return (plugin_hsc_env, mod_summary, status) +-- | Calculate the ModLocation from the provided DynFlags. This function is only used +-- in one-shot mode and therefore takes into account the effect of -o/-ohi flags +-- (which do nothing in --make mode) +mkOneShotModLocation :: PipeEnv -> DynFlags -> HscSource -> ModuleName -> IO ModLocation +mkOneShotModLocation pipe_env dflags src_flavour mod_name = do + let PipeEnv{ src_basename=basename, + src_suffix=suff } = pipe_env + let location1 = mkHomeModLocation2 fopts mod_name basename suff + + -- Boot-ify it if necessary + let location2 + | HsBootFile <- src_flavour = addBootSuffixLocnOut location1 + | otherwise = location1 + + + -- Take -ohi into account if present + -- This can't be done in mkHomeModuleLocation because + -- it only applies to the module being compiles + let ohi = outputHi dflags + location3 | Just fn <- ohi = location2{ ml_hi_file = fn } + | otherwise = location2 + + let dynohi = dynOutputHi dflags + location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file = fn } + | otherwise = location3 + + -- Take -o into account if present + -- Very like -ohi, but we must *only* do this if we aren't linking + -- (If we're linking then the -o applies to the linked thing, not to + -- the object file for one module.) + -- Note the nasty duplication with the same computation in compileFile + -- above + let expl_o_file = outputFile_ dflags + expl_dyn_o_file = dynOutputFile_ dflags + location5 | Just ofile <- expl_o_file + , let dyn_ofile = fromMaybe (ofile -<.> dynObjectSuf_ dflags) expl_dyn_o_file + , isNoLink (ghcLink dflags) + = location4 { ml_obj_file = ofile + , ml_dyn_obj_file = dyn_ofile } + | Just dyn_ofile <- expl_dyn_o_file + = location4 { ml_dyn_obj_file = dyn_ofile } + | otherwise = location4 + return location5 + where + fopts = initFinderOpts dflags + runHscTcPhase :: HscEnv -> ModSummary -> IO (FrontendResult, Messages GhcMessage) runHscTcPhase = hscTypecheckAndGetWarnings @@ -728,7 +775,11 @@ runHsPpPhase hsc_env orig_fn input_fn output_fn = do ] ) return output_fn -phaseOutputFilenameNew :: Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> IO FilePath +phaseOutputFilenameNew :: Phase -- ^ The next phase + -> PipeEnv + -> HscEnv + -> Maybe ModLocation -- ^ A ModLocation, if we are compiling a Haskell source file + -> IO FilePath phaseOutputFilenameNew next_phase pipe_env hsc_env maybe_loc = do let PipeEnv{stop_phase, src_basename, output_spec} = pipe_env let dflags = hsc_dflags hsc_env @@ -764,16 +815,37 @@ getOutputFilename -> Maybe ModLocation -> IO FilePath getOutputFilename logger tmpfs stop_phase output basename dflags next_phase maybe_location + -- 1. If we are generating object files for a .hs file, then return the odir as the ModLocation + -- will have been modified to point to the accurate locations + | StopLn <- next_phase, Just loc <- maybe_location = + return $ if dynamicNow dflags then ml_dyn_obj_file loc + else ml_obj_file loc + -- 2. If output style is persistant then | is_last_phase, Persistent <- output = persistent_fn - | is_last_phase, SpecificFile <- output = case outputFile dflags of - Just f -> return f - Nothing -> - panic "SpecificFile: No filename" + -- 3. Specific file is only set when outputFile is set by -o + -- If we are in dynamic mode but -dyno is not set then write to the same path as + -- -o with a .dyn_* extension. This case is not triggered for object files which + -- are always handled by the ModLocation. + | is_last_phase, SpecificFile <- output = + return $ + if dynamicNow dflags + then case dynOutputFile_ dflags of + Nothing -> let ofile = getOutputFile_ dflags + new_ext = case takeExtension ofile of + "" -> "dyn" + ext -> "dyn_" ++ tail ext + in replaceExtension ofile new_ext + Just fn -> fn + else getOutputFile_ dflags | keep_this_output = persistent_fn | Temporary lifetime <- output = newTempName logger tmpfs (tmpDir dflags) lifetime suffix | otherwise = newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule suffix where + getOutputFile_ dflags = case outputFile_ dflags of + Nothing -> pprPanic "SpecificFile: No filename" (ppr $ (dynamicNow dflags, outputFile_ dflags, dynOutputFile_ dflags)) + Just fn -> fn + hcsuf = hcSuf dflags odir = objectDir dflags osuf = objectSuf dflags @@ -808,7 +880,6 @@ getOutputFilename logger tmpfs stop_phase output basename dflags next_phase mayb persistent = basename <.> suffix odir_persistent - | Just loc <- maybe_location = ml_obj_file loc | Just d <- odir = (d </> persistent) | otherwise = persistent diff --git a/compiler/GHC/Driver/Pipeline/Monad.hs b/compiler/GHC/Driver/Pipeline/Monad.hs index f9067576ae..5415ecf2fe 100644 --- a/compiler/GHC/Driver/Pipeline/Monad.hs +++ b/compiler/GHC/Driver/Pipeline/Monad.hs @@ -7,19 +7,13 @@ module GHC.Driver.Pipeline.Monad ( , PipeEnv(..) , PipelineOutput(..) - , getLocation ) where import GHC.Prelude import Control.Monad.IO.Class import qualified Data.Kind as K import GHC.Driver.Phases -import GHC.Driver.Config.Finder import GHC.Utils.TmpFs -import GHC.Driver.Session -import GHC.Types.SourceFile -import GHC.Unit.Module -import GHC.Unit.Finder -- The interface that the pipeline monad must implement. type TPipelineClass (f :: K.Type -> K.Type) (m :: K.Type -> K.Type) @@ -38,40 +32,6 @@ data PipeEnv = PipeEnv { output_spec :: PipelineOutput -- ^ says where to put the pipeline output } --- | Calculate the ModLocation from the provided DynFlags -getLocation :: PipeEnv -> DynFlags -> HscSource -> ModuleName -> IO ModLocation -getLocation pipe_env dflags src_flavour mod_name = do - let PipeEnv{ src_basename=basename, - src_suffix=suff } = pipe_env - location1 <- mkHomeModLocation2 fopts mod_name basename suff - - -- Boot-ify it if necessary - let location2 - | HsBootFile <- src_flavour = addBootSuffixLocnOut location1 - | otherwise = location1 - - - -- Take -ohi into account if present - -- This can't be done in mkHomeModuleLocation because - -- it only applies to the module being compiles - let ohi = outputHi dflags - location3 | Just fn <- ohi = location2{ ml_hi_file = fn } - | otherwise = location2 - - -- Take -o into account if present - -- Very like -ohi, but we must *only* do this if we aren't linking - -- (If we're linking then the -o applies to the linked thing, not to - -- the object file for one module.) - -- Note the nasty duplication with the same computation in compileFile - -- above - let expl_o_file = outputFile dflags - location4 | Just ofile <- expl_o_file - , isNoLink (ghcLink dflags) - = location3 { ml_obj_file = ofile } - | otherwise = location3 - return location4 - where - fopts = initFinderOpts dflags data PipelineOutput = Temporary TempFileLifetime diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 12f0e8be33..3342091bfa 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -38,10 +38,9 @@ module GHC.Driver.Session ( xopt_FieldSelectors, lang_set, DynamicTooState(..), dynamicTooState, setDynamicNow, setDynamicTooFailed, - dynamicOutputFile, dynamicOutputHi, sccProfilingEnabled, DynFlags(..), - outputFile, hiSuf, objectSuf, ways, + outputFile, objectSuf, ways, FlagSpec(..), HasDynFlags(..), ContainsDynFlags(..), RtsOptsEnabled(..), @@ -1059,13 +1058,6 @@ setDynamicTooFailed :: MonadIO m => DynFlags -> m () setDynamicTooFailed dflags = liftIO $ writeIORef (dynamicTooFailed dflags) True --- | Compute the path of the dynamic object corresponding to an object file. -dynamicOutputFile :: DynFlags -> FilePath -> FilePath -dynamicOutputFile dflags outputFile = outputFile -<.> dynObjectSuf_ dflags - -dynamicOutputHi :: DynFlags -> FilePath -> FilePath -dynamicOutputHi dflags hi = hi -<.> dynHiSuf_ dflags - ----------------------------------------------------------------------------- -- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value @@ -1873,26 +1865,19 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do throwGhcExceptionIO (CmdLineError ("combination not supported: " ++ intercalate "/" (map wayDesc (Set.toAscList theWays)))) - let dflags3 - | Just outFile <- outputFile_ dflags2 -- Only iff user specified -o ... - , not (isJust (dynOutputFile_ dflags2)) -- but not -dyno - = dflags2 { dynOutputFile_ = Just $ dynamicOutputFile dflags2 outFile } - | otherwise - = dflags2 - - let (dflags4, consistency_warnings) = makeDynFlagsConsistent dflags3 + let (dflags3, consistency_warnings) = makeDynFlagsConsistent dflags2 -- Set timer stats & heap size - when (enableTimeStats dflags4) $ liftIO enableTimingStats - case (ghcHeapSize dflags4) of + when (enableTimeStats dflags3) $ liftIO enableTimingStats + case (ghcHeapSize dflags3) of Just x -> liftIO (setHeapSize x) _ -> return () - liftIO $ setUnsafeGlobalDynFlags dflags4 + liftIO $ setUnsafeGlobalDynFlags dflags3 let warns' = map (Warn WarningWithoutFlag) (consistency_warnings ++ sh_warns) - return (dflags4, leftover, warns' ++ warns) + return (dflags3, leftover, warns' ++ warns) -- | Check (and potentially disable) any extensions that aren't allowed -- in safe mode. @@ -4874,11 +4859,6 @@ outputFile dflags | dynamicNow dflags = dynOutputFile_ dflags | otherwise = outputFile_ dflags -hiSuf :: DynFlags -> String -hiSuf dflags - | dynamicNow dflags = dynHiSuf_ dflags - | otherwise = hiSuf_ dflags - objectSuf :: DynFlags -> String objectSuf dflags | dynamicNow dflags = dynObjectSuf_ dflags diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 2b31074896..64df715755 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -912,10 +912,10 @@ findAndReadIface logger name_cache fc hooks unit_state home_unit dflags doc_str case r of Failed _ -> return () - Succeeded (iface,fp) + Succeeded (iface,_fp) -> load_dynamic_too_maybe logger name_cache unit_state dflags wanted_mod - hi_boot_file iface fp + hi_boot_file iface loc return r err -> do trace_if logger (text "...not found") @@ -928,20 +928,20 @@ findAndReadIface logger name_cache fc hooks unit_state home_unit dflags doc_str err -- | Check if we need to try the dynamic interface for -dynamic-too -load_dynamic_too_maybe :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> IsBootInterface -> ModIface -> FilePath -> IO () -load_dynamic_too_maybe logger name_cache unit_state dflags wanted_mod is_boot iface file_path +load_dynamic_too_maybe :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> IsBootInterface -> ModIface -> ModLocation -> IO () +load_dynamic_too_maybe logger name_cache unit_state dflags wanted_mod is_boot iface loc -- Indefinite interfaces are ALWAYS non-dynamic. | not (moduleIsDefinite (mi_module iface)) = return () | otherwise = dynamicTooState dflags >>= \case DT_Dont -> return () DT_Failed -> return () - DT_Dyn -> load_dynamic_too logger name_cache unit_state dflags wanted_mod is_boot iface file_path - DT_OK -> load_dynamic_too logger name_cache unit_state (setDynamicNow dflags) wanted_mod is_boot iface file_path + DT_Dyn -> load_dynamic_too logger name_cache unit_state dflags wanted_mod iface file_path + DT_OK -> load_dynamic_too logger name_cache unit_state (setDynamicNow dflags) wanted_mod iface file_path + where + file_path = addBootSuffix_maybe is_boot (ml_dyn_hi_file loc) -load_dynamic_too :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> IsBootInterface -> ModIface -> FilePath -> IO () -load_dynamic_too logger name_cache unit_state dflags wanted_mod is_boot iface file_path = do - let dynFilePath = addBootSuffix_maybe is_boot - $ replaceExtension file_path (hiSuf dflags) +load_dynamic_too :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> FilePath -> IO () +load_dynamic_too logger name_cache unit_state dflags wanted_mod iface dynFilePath = do read_file logger name_cache unit_state dflags wanted_mod dynFilePath >>= \case Succeeded (dynIface, _) | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) diff --git a/compiler/GHC/Linker/Dynamic.hs b/compiler/GHC/Linker/Dynamic.hs index 3eca65c6cc..c62a6e2242 100644 --- a/compiler/GHC/Linker/Dynamic.hs +++ b/compiler/GHC/Linker/Dynamic.hs @@ -44,7 +44,7 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages = dflags0 verbFlags = getVerbFlags dflags - o_file = outputFile dflags + o_file = outputFile_ dflags pkgs_with_rts <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages) diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs index 3cdee27863..2af6f4dfe1 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -615,7 +615,7 @@ checkNonStdWay dflags interp srcspan -- Only if we are compiling with the same ways as GHC is built -- with, can we dynamically load those object files. (see #3604) - | objectSuf dflags == normalObjectSuffix && not (null targetFullWays) + | objectSuf_ dflags == normalObjectSuffix && not (null targetFullWays) = failNonStd dflags srcspan | otherwise = return (Just (hostWayTag ++ "o")) @@ -663,7 +663,7 @@ failNonStd dflags srcspan = dieWith dflags srcspan $ getLinkDeps :: HscEnv -> HomePackageTable -> LoaderState - -> Maybe FilePath -- replace object suffices? + -> Maybe FilePath -- replace object suffixes? -> SrcSpan -- for error messages -> [Module] -- If you need these -> IO ([Linkable], [Linkable], [UnitId]) -- ... then link these first diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs index ed67daa347..d5e9147509 100644 --- a/compiler/GHC/Linker/Static.hs +++ b/compiler/GHC/Linker/Static.hs @@ -73,7 +73,7 @@ linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do unit_state = ue_units unit_env toolSettings' = toolSettings dflags verbFlags = getVerbFlags dflags - output_fn = exeFileName platform staticLink (outputFile dflags) + output_fn = exeFileName platform staticLink (outputFile_ dflags) -- get the full list of packages to link with, by combining the -- explicit packages with the auto packages and all of their @@ -277,7 +277,7 @@ linkStaticLib logger dflags unit_env o_files dep_units = do let platform = ue_platform unit_env extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] modules = o_files ++ extra_ld_inputs - output_fn = exeFileName platform True (outputFile dflags) + output_fn = exeFileName platform True (outputFile_ dflags) full_output_fn <- if isAbsolute output_fn then return output_fn diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs index f0ecfb2ba7..8a402dca15 100644 --- a/compiler/GHC/Unit/Finder.hs +++ b/compiler/GHC/Unit/Finder.hs @@ -123,37 +123,6 @@ lookupFileCache (FinderCache _ ref) key = do -- ----------------------------------------------------------------------------- -- The three external entry points --- | Locations and information the finder cares about. --- --- Should be taken from 'DynFlags' via 'initFinderOpts'. -data FinderOpts = FinderOpts - { finder_importPaths :: [FilePath] - -- ^ Where are we allowed to look for Modules and Source files - , finder_lookupHomeInterfaces :: Bool - -- ^ When looking up a home module: - -- - -- * 'True': search interface files (e.g. in '-c' mode) - -- * 'False': search source files (e.g. in '--make' mode) - - , finder_bypassHiFileCheck :: Bool - -- ^ Don't check that an imported interface file actually exists - -- if it can only be at one location. The interface will be reported - -- as `InstalledFound` even if the file doesn't exist, so this is - -- only useful in specific cases (e.g. to generate dependencies - -- with `ghc -M`) - , finder_ways :: Ways - , finder_enableSuggestions :: Bool - -- ^ If we encounter unknown modules, should we suggest modules - -- that have a similar name. - , finder_hieDir :: Maybe FilePath - , finder_hieSuf :: String - , finder_hiDir :: Maybe FilePath - , finder_hiSuf :: String - , finder_objectDir :: Maybe FilePath - , finder_objectSuf :: String - , finder_stubDir :: Maybe FilePath - } - -- | Locate a module that was imported by the user. We have the -- module's name, and possibly a package name. Without a package @@ -424,19 +393,21 @@ findPackageModule_ fc fopts mod pkg_conf = do package_hisuf | null tag = "hi" | otherwise = tag ++ "_hi" - mk_hi_loc = mkHiOnlyModLocation fopts package_hisuf + package_dynhisuf = waysBuildTag (addWay WayDyn (finder_ways fopts)) ++ "_hi" + + mk_hi_loc = mkHiOnlyModLocation fopts package_hisuf package_dynhisuf import_dirs = map ST.unpack $ unitImportDirs pkg_conf -- we never look for a .hi-boot file in an external package; -- .hi-boot files only make sense for the home package. in case import_dirs of - [one] | finder_bypassHiFileCheck fopts -> do + [one] | finder_bypassHiFileCheck fopts -> -- there's only one place that this .hi file can be, so -- don't bother looking for it. let basename = moduleNameSlashes (moduleName mod) - loc <- mk_hi_loc one basename - return (InstalledFound loc mod) + loc = mk_hi_loc one basename + in return $ InstalledFound loc mod _otherwise -> searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)] @@ -446,8 +417,8 @@ findPackageModule_ fc fopts mod pkg_conf = do searchPathExts :: [FilePath] -- paths to search -> InstalledModule -- module name -> [ ( - FileExt, -- suffix - FilePath -> BaseName -> IO ModLocation -- action + FileExt, -- suffix + FilePath -> BaseName -> ModLocation -- action ) ] -> IO InstalledFindResult @@ -456,7 +427,7 @@ searchPathExts paths mod exts = search to_search where basename = moduleNameSlashes (moduleName mod) - to_search :: [(FilePath, IO ModLocation)] + to_search :: [(FilePath, ModLocation)] to_search = [ (file, fn path basename) | path <- paths, (ext,fn) <- exts, @@ -467,17 +438,18 @@ searchPathExts paths mod exts = search to_search search [] = return (InstalledNotFound (map fst to_search) (Just (moduleUnit mod))) - search ((file, mk_result) : rest) = do + search ((file, loc) : rest) = do b <- doesFileExist file if b - then do { loc <- mk_result; return (InstalledFound loc mod) } + then return $ InstalledFound loc mod else search rest mkHomeModLocationSearched :: FinderOpts -> ModuleName -> FileExt - -> FilePath -> BaseName -> IO ModLocation + -> FilePath -> BaseName -> ModLocation mkHomeModLocationSearched fopts mod suff path basename = mkHomeModLocation2 fopts mod (path </> basename) suff + -- ----------------------------------------------------------------------------- -- Constructing a home module location @@ -511,49 +483,59 @@ mkHomeModLocationSearched fopts mod suff path basename = -- ext -- The filename extension of the source file (usually "hs" or "lhs"). -mkHomeModLocation :: FinderOpts -> ModuleName -> FilePath -> IO ModLocation -mkHomeModLocation dflags mod src_filename = do +mkHomeModLocation :: FinderOpts -> ModuleName -> FilePath -> ModLocation +mkHomeModLocation dflags mod src_filename = let (basename,extension) = splitExtension src_filename - mkHomeModLocation2 dflags mod basename extension + in mkHomeModLocation2 dflags mod basename extension mkHomeModLocation2 :: FinderOpts -> ModuleName -> FilePath -- Of source module, without suffix -> String -- Suffix - -> IO ModLocation -mkHomeModLocation2 fopts mod src_basename ext = do + -> ModLocation +mkHomeModLocation2 fopts mod src_basename ext = let mod_basename = moduleNameSlashes mod obj_fn = mkObjPath fopts src_basename mod_basename + dyn_obj_fn = mkDynObjPath fopts src_basename mod_basename hi_fn = mkHiPath fopts src_basename mod_basename + dyn_hi_fn = mkDynHiPath fopts src_basename mod_basename hie_fn = mkHiePath fopts src_basename mod_basename - return (ModLocation{ ml_hs_file = Just (src_basename <.> ext), + in (ModLocation{ ml_hs_file = Just (src_basename <.> ext), ml_hi_file = hi_fn, + ml_dyn_hi_file = dyn_hi_fn, ml_obj_file = obj_fn, + ml_dyn_obj_file = dyn_obj_fn, ml_hie_file = hie_fn }) mkHomeModHiOnlyLocation :: FinderOpts -> ModuleName -> FilePath -> BaseName - -> IO ModLocation -mkHomeModHiOnlyLocation fopts mod path basename = do - loc <- mkHomeModLocation2 fopts mod (path </> basename) "" - return loc { ml_hs_file = Nothing } - -mkHiOnlyModLocation :: FinderOpts -> Suffix -> FilePath -> String - -> IO ModLocation -mkHiOnlyModLocation fopts hisuf path basename - = do let full_basename = path </> basename - obj_fn = mkObjPath fopts full_basename basename - hie_fn = mkHiePath fopts full_basename basename - return ModLocation{ ml_hs_file = Nothing, + -> ModLocation +mkHomeModHiOnlyLocation fopts mod path basename = + let loc = mkHomeModLocation2 fopts mod (path </> basename) "" + in loc { ml_hs_file = Nothing } + +-- This function is used to make a ModLocation for a package module. Hence why +-- we explicitly pass in the interface file suffixes. +mkHiOnlyModLocation :: FinderOpts -> Suffix -> Suffix -> FilePath -> String + -> ModLocation +mkHiOnlyModLocation fopts hisuf dynhisuf path basename + = let full_basename = path </> basename + obj_fn = mkObjPath fopts full_basename basename + dyn_obj_fn = mkDynObjPath fopts full_basename basename + hie_fn = mkHiePath fopts full_basename basename + in ModLocation{ ml_hs_file = Nothing, ml_hi_file = full_basename <.> hisuf, -- Remove the .hi-boot suffix from -- hi_file, if it had one. We always -- want the name of the real .hi file -- in the ml_hi_file field. + ml_dyn_obj_file = dyn_obj_fn, + -- MP: TODO + ml_dyn_hi_file = full_basename <.> dynhisuf, ml_obj_file = obj_fn, ml_hie_file = hie_fn } @@ -573,6 +555,21 @@ mkObjPath fopts basename mod_basename = obj_basename <.> osuf obj_basename | Just dir <- odir = dir </> mod_basename | otherwise = basename +-- | Constructs the filename of a .dyn_o file for a given source file. +-- Does /not/ check whether the .dyn_o file exists +mkDynObjPath + :: FinderOpts + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> FilePath +mkDynObjPath fopts basename mod_basename = obj_basename <.> dynosuf + where + odir = finder_objectDir fopts + dynosuf = finder_dynObjectSuf fopts + + obj_basename | Just dir <- odir = dir </> mod_basename + | otherwise = basename + -- | Constructs the filename of a .hi file for a given source file. -- Does /not/ check whether the .hi file exists @@ -589,6 +586,21 @@ mkHiPath fopts basename mod_basename = hi_basename <.> hisuf hi_basename | Just dir <- hidir = dir </> mod_basename | otherwise = basename +-- | Constructs the filename of a .dyn_hi file for a given source file. +-- Does /not/ check whether the .dyn_hi file exists +mkDynHiPath + :: FinderOpts + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> FilePath +mkDynHiPath fopts basename mod_basename = hi_basename <.> dynhisuf + where + hidir = finder_hiDir fopts + dynhisuf = finder_dynHiSuf fopts + + hi_basename | Just dir <- hidir = dir </> mod_basename + | otherwise = basename + -- | Constructs the filename of a .hie file for a given source file. -- Does /not/ check whether the .hie file exists mkHiePath diff --git a/compiler/GHC/Unit/Finder/Types.hs b/compiler/GHC/Unit/Finder/Types.hs index d589cacbba..26baea564c 100644 --- a/compiler/GHC/Unit/Finder/Types.hs +++ b/compiler/GHC/Unit/Finder/Types.hs @@ -3,6 +3,7 @@ module GHC.Unit.Finder.Types , FinderCacheState , FindResult (..) , InstalledFindResult (..) + , FinderOpts(..) ) where @@ -10,6 +11,7 @@ import GHC.Prelude import GHC.Unit import qualified Data.Map as M import GHC.Fingerprint +import GHC.Platform.Ways import Data.IORef @@ -62,3 +64,35 @@ data FindResult , fr_suggestions :: [ModuleSuggestion] -- ^ Possible mis-spelled modules } +-- | Locations and information the finder cares about. +-- +-- Should be taken from 'DynFlags' via 'initFinderOpts'. +data FinderOpts = FinderOpts + { finder_importPaths :: [FilePath] + -- ^ Where are we allowed to look for Modules and Source files + , finder_lookupHomeInterfaces :: Bool + -- ^ When looking up a home module: + -- + -- * 'True': search interface files (e.g. in '-c' mode) + -- * 'False': search source files (e.g. in '--make' mode) + + , finder_bypassHiFileCheck :: Bool + -- ^ Don't check that an imported interface file actually exists + -- if it can only be at one location. The interface will be reported + -- as `InstalledFound` even if the file doesn't exist, so this is + -- only useful in specific cases (e.g. to generate dependencies + -- with `ghc -M`) + , finder_ways :: Ways + , finder_enableSuggestions :: Bool + -- ^ If we encounter unknown modules, should we suggest modules + -- that have a similar name. + , finder_hieDir :: Maybe FilePath + , finder_hieSuf :: String + , finder_hiDir :: Maybe FilePath + , finder_hiSuf :: String + , finder_dynHiSuf :: String + , finder_objectDir :: Maybe FilePath + , finder_objectSuf :: String + , finder_dynObjectSuf :: String + , finder_stubDir :: Maybe FilePath + } diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs index 027cbef51b..bf7abfea99 100644 --- a/compiler/GHC/Unit/Module/Graph.hs +++ b/compiler/GHC/Unit/Module/Graph.hs @@ -204,7 +204,7 @@ showModMsg dflags recomp (ModuleNode (ExtendedModSummary mod_summary _)) = op = normalise mod = moduleName (ms_mod mod_summary) mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary) - dyn_file = op $ msDynObjFilePath mod_summary dflags + dyn_file = op $ msDynObjFilePath mod_summary obj_file = case backend dflags of Interpreter | recomp -> "interpreted" NoBackend -> "nothing" diff --git a/compiler/GHC/Unit/Module/Location.hs b/compiler/GHC/Unit/Module/Location.hs index ff5354bfdb..866ccf127a 100644 --- a/compiler/GHC/Unit/Module/Location.hs +++ b/compiler/GHC/Unit/Module/Location.hs @@ -16,7 +16,7 @@ import GHC.Utils.Outputable -- | Module Location -- -- Where a module lives on the file system: the actual locations --- of the .hs, .hi and .o files, if we have them. +-- of the .hs, .hi, .dyn_hi, .o, .dyn_o and .hie files, if we have them. -- -- For a module in another unit, the ml_hs_file and ml_obj_file components of -- ModLocation are undefined. @@ -25,6 +25,16 @@ import GHC.Utils.Outputable -- correspond to actual files yet: for example, even if the object -- file doesn't exist, the ModLocation still contains the path to -- where the object file will reside if/when it is created. +-- +-- The paths of anything which can affect recompilation should be placed inside +-- ModLocation. +-- +-- When a ModLocation is created none of the filepaths will have -boot suffixes. +-- This is because in --make mode the ModLocation is put in the finder cache which +-- is indexed by ModuleName, when a ModLocation is retrieved from the FinderCache +-- the boot suffixes are appended. +-- The other case is in -c mode, there the ModLocation immediately gets given the +-- boot suffixes in mkOneShotModLocation. data ModLocation = ModLocation { @@ -37,12 +47,20 @@ data ModLocation -- yet. Always of form foo.hi, even if there is an -- hi-boot file (we add the -boot suffix later) + ml_dyn_hi_file :: FilePath, + -- ^ Where the .dyn_hi file is, whether or not it exists + -- yet. + ml_obj_file :: FilePath, -- ^ Where the .o file is, whether or not it exists yet. -- (might not exist either because the module hasn't -- been compiled yet, or because it is part of a -- unit with a .a file) + ml_dyn_obj_file :: FilePath, + -- ^ Where the .dy file is, whether or not it exists + -- yet. + ml_hie_file :: FilePath -- ^ Where the .hie file is, whether or not it exists -- yet. @@ -73,7 +91,9 @@ addBootSuffixLocn :: ModLocation -> ModLocation addBootSuffixLocn locn = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn) , ml_hi_file = addBootSuffix (ml_hi_file locn) + , ml_dyn_hi_file = addBootSuffix (ml_dyn_hi_file locn) , ml_obj_file = addBootSuffix (ml_obj_file locn) + , ml_dyn_obj_file = addBootSuffix (ml_dyn_obj_file locn) , ml_hie_file = addBootSuffix (ml_hie_file locn) } -- | Add the @-boot@ suffix to all output file paths associated with the @@ -81,7 +101,10 @@ addBootSuffixLocn locn addBootSuffixLocnOut :: ModLocation -> ModLocation addBootSuffixLocnOut locn = locn { ml_hi_file = addBootSuffix (ml_hi_file locn) + , ml_dyn_hi_file = addBootSuffix (ml_dyn_hi_file locn) , ml_obj_file = addBootSuffix (ml_obj_file locn) - , ml_hie_file = addBootSuffix (ml_hie_file locn) } + , ml_dyn_obj_file = addBootSuffix (ml_dyn_obj_file locn) + , ml_hie_file = addBootSuffix (ml_hie_file locn) + } diff --git a/compiler/GHC/Unit/Module/ModSummary.hs b/compiler/GHC/Unit/Module/ModSummary.hs index 1a8cddec61..9cf736a37a 100644 --- a/compiler/GHC/Unit/Module/ModSummary.hs +++ b/compiler/GHC/Unit/Module/ModSummary.hs @@ -156,8 +156,8 @@ msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms)) msHiFilePath ms = ml_hi_file (ms_location ms) msObjFilePath ms = ml_obj_file (ms_location ms) -msDynObjFilePath :: ModSummary -> DynFlags -> FilePath -msDynObjFilePath ms dflags = dynamicOutputFile dflags (msObjFilePath ms) +msDynObjFilePath :: ModSummary -> FilePath +msDynObjFilePath ms = ml_dyn_obj_file (ms_location ms) -- | Did this 'ModSummary' originate from a hs-boot file? isBootSummary :: ModSummary -> IsBootInterface |