diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 13e6c87fe93e..27407b787487 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -1389,21 +1389,18 @@ hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do if (write_interface || force_write_interface) then do - -- FIXME: with -dynamic-too, "change" is only meaningful for the - -- non-dynamic interface, not for the dynamic one. We should have another - -- flag for the dynamic interface. In the meantime: - -- - -- * when we write a single full interface, we check if we are - -- currently writing the dynamic interface due to -dynamic-too, in - -- which case we ignore "change". - -- - -- * when we write two simple interfaces at once because of - -- dynamic-too, we use "change" both for the non-dynamic and the - -- dynamic interfaces. Hopefully both the dynamic and the non-dynamic - -- interfaces stay in sync... - -- let change = old_iface /= Just (mi_iface_hash iface) + -- Create a relative symlink from .dyn_hi -> .hi. + -- Used when -dynamic-too is active (deprecated). + let symlink_dyn_hi = do + let hi_file = ml_hi_file mod_location + dyn_hi_file = ml_dyn_hi_file mod_location + rel_hi = FilePath.takeFileName hi_file + exists <- doesPathExist dyn_hi_file + when exists $ removeFile dyn_hi_file + createFileLink rel_hi dyn_hi_file + let dt = dynamicTooState dflags when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger $ @@ -1414,16 +1411,20 @@ hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do ] if is_simple - then when change $ do -- FIXME: see 'change' comment above + then when change $ do write_iface dflags iface case dt of DT_Dont -> return () DT_Dyn -> panic "Unexpected DT_Dyn state when writing simple interface" - DT_OK -> write_iface (setDynamicNow dflags) iface + -- -dynamic-too is deprecated: create a symlink .dyn_hi -> .hi + -- instead of writing a second copy of the interface file. + DT_OK -> symlink_dyn_hi else case dt of DT_Dont | change -> write_iface dflags iface - DT_OK | change -> write_iface dflags iface - -- FIXME: see change' comment above + DT_OK | change -> do + write_iface dflags iface + -- -dynamic-too is deprecated: create .dyn_hi -> .hi symlink + symlink_dyn_hi DT_Dyn -> write_iface dflags iface _ -> return () diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 1b85504e21d5..b5c032407441 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -787,23 +787,33 @@ hscBackendPipeline pipe_env hsc_env mod_sum result = if backendGeneratesCode (backend (hsc_dflags hsc_env)) then do res <- hscGenBackendPipeline pipe_env hsc_env mod_sum result - -- Only run dynamic-too if the backend generates object files - -- See Note [Writing interface files] - -- If we are writing a simple interface (not . backendWritesFiles), then - -- hscMaybeWriteIface in the regular pipeline will write both the hi and - -- dyn_hi files. This way we can avoid running the pipeline twice and - -- generating a duplicate linkable. - -- We must not run the backend a second time with `dynamicNow` enable because - -- all the work has already been done in the first pipeline. - when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env) && backendWritesFiles (backend (hsc_dflags hsc_env)) ) $ do - let dflags' = setDynamicNow (hsc_dflags hsc_env) -- set "dynamicNow" - () <$ hscGenBackendPipeline pipe_env (hscSetFlags dflags' hsc_env) mod_sum result + -- -dynamic-too is deprecated: instead of running the backend a second + -- time to produce .dyn_o files, we create a symlink .dyn_o -> .o + -- since all object files are now dynamic-capable. + when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env) && backendWritesFiles (backend (hsc_dflags hsc_env)) ) $ liftIO $ do + let location = ms_location mod_sum + obj_fn = ml_obj_file location + dyn_obj_fn = ml_dyn_obj_file location + createOrUpdateSymlink obj_fn dyn_obj_fn return res else case result of HscUpdate iface -> return (iface, emptyHomeModInfoLinkable) HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing NoStubs []) <*> pure emptyHomeModInfoLinkable +-- | Create a symlink from @link@ pointing to @source@, removing any +-- existing file or symlink at @link@ first. Used by the deprecated +-- -dynamic-too path to create .dyn_o -> .o and .dyn_hi -> .hi symlinks. +createOrUpdateSymlink :: FilePath -> FilePath -> IO () +createOrUpdateSymlink source link = do + -- Use the basename of source so the symlink is relative + -- (both files live in the same directory). + let relSource = takeFileName source + -- doesPathExist detects files, directories, and symlinks (including broken ones) + exists <- doesPathExist link + when exists $ removeFile link + createFileLink relSource link + hscGenBackendPipeline :: P m => PipeEnv -> HscEnv diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index f84fcc447cf6..3f79d6864049 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -1325,8 +1325,9 @@ dynamic_flags_deps = [ , make_ord_flag defGhcFlag "ddump-file-prefix" (hasArg (setDumpPrefixForce . Just . flip (++) ".")) - , make_ord_flag defGhcFlag "dynamic-too" + , make_dep_flag defGhcFlag "dynamic-too" (NoArg (setGeneralFlag Opt_BuildDynamicToo)) + "-dynamic-too is deprecated. All object files are now dynamic-capable; .dyn_o/.dyn_hi are created as symlinks." ------- Keeping temporary files ------------------------------------- -- These can be singular (think ghc -c) or plural (think ghc --make) diff --git a/compiler/GHC/Linker/Deps.hs b/compiler/GHC/Linker/Deps.hs index 0f36a791b47c..8a68b35b12f4 100644 --- a/compiler/GHC/Linker/Deps.hs +++ b/compiler/GHC/Linker/Deps.hs @@ -244,9 +244,12 @@ checkNonStdWay _opts interp _srcspan -- -dynamic-too) | ldForceDyn _opts = do let target_ways = fullWays $ ldWays _opts - pure $ if target_ways `hasWay` WayDyn + -- Ignore WayDyn: since -dynamic-too is deprecated, .dyn_o files are + -- symlinks to .o files. Use the plain .o suffix. + let non_dyn_ways = removeWay WayDyn target_ways + pure $ if null (waysTag non_dyn_ways) then Nothing - else Just $ waysTag (WayDyn `addWay` target_ways) ++ "_o" + else Just $ waysTag non_dyn_ways ++ "_o" | ExternalInterp {} <- interpInstance interp = return Nothing -- with -fexternal-interpreter we load the .o files, whatever way @@ -257,17 +260,21 @@ checkNonStdWay _opts interp _srcspan -- complain that they are redundant. #if defined(HAVE_INTERNAL_INTERPRETER) checkNonStdWay opts _interp srcspan - | hostFullWays == targetFullWays = return Nothing + -- Ignore WayDyn when comparing host and target ways: since -dynamic-too + -- is deprecated, WayDyn no longer affects object file suffixes. + | removeWay WayDyn hostFullWays == removeWay WayDyn targetFullWays + = return Nothing -- Only if we are compiling with the same ways as GHC is built -- with, can we dynamically load those object files. (see #3604) - | ldObjSuffix opts == normalObjectSuffix && not (null targetFullWays) + | ldObjSuffix opts == normalObjectSuffix && not (null targetNonDynWays) = failNonStd opts srcspan | otherwise = return (Just (hostWayTag ++ "o")) where targetFullWays = fullWays (ldWays opts) - hostWayTag = case waysTag hostFullWays of + targetNonDynWays = waysTag (removeWay WayDyn targetFullWays) + hostWayTag = case waysTag (removeWay WayDyn hostFullWays) of "" -> "" tag -> tag ++ "_" diff --git a/compiler/GHC/Platform/Profile.hs b/compiler/GHC/Platform/Profile.hs index d474ff34c8e7..89d43cbd5f70 100644 --- a/compiler/GHC/Platform/Profile.hs +++ b/compiler/GHC/Platform/Profile.hs @@ -50,4 +50,8 @@ profileBuildTag profile | otherwise = wayTag where platform = profilePlatform profile - wayTag = waysBuildTag (profileWays profile) + -- Ignore WayDyn: since -dynamic-too is deprecated and .dyn_hi/.dyn_o are + -- now symlinks to .hi/.o, the interface file profile tag must be consistent + -- regardless of whether -dynamic is active. Only non-dynamic ways (e.g. + -- profiling) contribute to the build tag. + wayTag = waysBuildTag (removeWay WayDyn (profileWays profile))