[Git][ghc/ghc][wip/23305] 3 commits: Fix behaviour of -keep-tmp-files when used in OPTIONS_GHC pragma
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Thu May 4 14:53:47 UTC 2023
Matthew Pickering pushed to branch wip/23305 at Glasgow Haskell Compiler / GHC
Commits:
306ad553 by Matthew Pickering at 2023-05-04T15:53:37+01:00
Fix behaviour of -keep-tmp-files when used in OPTIONS_GHC pragma
This fixes the behaviour of -keep-tmp-files when used in an OPTIONS_GHC
pragma for files with module level scope.
Instead of simple not deleting the files, we also need to remove them
from the TmpFs so they are not deleted later on when all the other files
are deleted.
There are additional complications because you also need to remove the
directory where these files live from the TmpFs so we don't try to
delete those later either.
I added two tests.
1. Tests simply that -keep-tmp-files works at all with a single module
and --make mode.
2. The other tests that temporary files are deleted for other modules
which don't enable -keep-tmp-files.
Fixes #23339
- - - - -
2d6d27de by Matthew Pickering at 2023-05-04T15:53:37+01:00
withDeferredDiagnostics: When debugIsOn, write landmine into IORef to catch use-after-free.
Ticket #23305 reports an error where we were attempting to use the
logger which was created by withDeferredDiagnostics after its scope had
ended.
This problem would have been caught by this patch and a validate build:
```
+*** Exception: Use after free
+CallStack (from HasCallStack):
+ error, called at compiler/GHC/Driver/Make.hs:<line>:<column> in <package-id>:GHC.Driver.Make
```
This general issue is tracked by #20981
- - - - -
384c9a2f by Matthew Pickering at 2023-05-04T15:53:37+01:00
Don't return complete HscEnv from upsweep
By returning a complete HscEnv from upsweep the logger (as introduced by
withDeferredDiagnostics) was escaping the scope of
withDeferredDiagnostics and hence we were losing error messages.
This is reminiscent of #20981, which also talks about writing errors
into messages after their scope has ended.
See #23305 for details.
- - - - -
9 changed files:
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Utils/TmpFs.hs
- testsuite/tests/driver/Makefile
- + testsuite/tests/driver/T23339.hs
- + testsuite/tests/driver/T23339.stdout
- + testsuite/tests/driver/T23339B.hs
- + testsuite/tests/driver/T23339B.stdout
- testsuite/tests/driver/all.T
- testsuite/tests/ghci/prog018/prog018.stdout
Changes:
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -772,16 +772,14 @@ load' mhmi_cache how_much mHscMessage mod_graph = do
worker_limit <- liftIO $ mkWorkerLimit dflags
setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env
- (upsweep_ok, hsc_env1) <- withDeferredDiagnostics $ do
+ (upsweep_ok, new_deps) <- withDeferredDiagnostics $ do
hsc_env <- getSession
liftIO $ upsweep worker_limit hsc_env mhmi_cache mHscMessage (toCache pruned_cache) build_plan
- setSession hsc_env1
+ modifySession (addDepsToHscEnv new_deps)
case upsweep_ok of
Failed -> loadFinish upsweep_ok
Succeeded -> do
liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.")
- -- Clean up after ourselves
- liftIO $ cleanCurrentModuleTempFilesMaybe logger (hsc_tmpfs hsc_env1) dflags
loadFinish upsweep_ok
@@ -1250,14 +1248,13 @@ upsweep
-> Maybe Messager
-> M.Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
- -> IO (SuccessFlag, HscEnv)
+ -> IO (SuccessFlag, [HomeModInfo])
upsweep n_jobs hsc_env hmi_cache mHscMessage old_hpt build_plan = do
(cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) hmi_cache old_hpt build_plan
runPipelines n_jobs hsc_env mHscMessage pipelines
res <- collect_result
let completed = [m | Just (Just m) <- res]
- let hsc_env' = addDepsToHscEnv completed hsc_env
-- Handle any cycle in the original compilation graph and return the result
-- of the upsweep.
@@ -1265,10 +1262,10 @@ upsweep n_jobs hsc_env hmi_cache mHscMessage old_hpt build_plan = do
Just mss -> do
let logger = hsc_logger hsc_env
liftIO $ fatalErrorMsg logger (cyclicModuleErr mss)
- return (Failed, hsc_env)
+ return (Failed, [])
Nothing -> do
let success_flag = successIf (all isJust res)
- return (success_flag, hsc_env')
+ return (success_flag, completed)
toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo
toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis])
@@ -2331,18 +2328,21 @@ withDeferredDiagnostics f = do
let action = logMsg logger msgClass srcSpan msg
case msgClass of
MCDiagnostic SevWarning _reason _code
- -> atomicModifyIORef' warnings $ \i -> (action: i, ())
+ -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ())
MCDiagnostic SevError _reason _code
- -> atomicModifyIORef' errors $ \i -> (action: i, ())
+ -> atomicModifyIORef' errors $ \(!i) -> (action: i, ())
MCFatal
- -> atomicModifyIORef' fatals $ \i -> (action: i, ())
+ -> atomicModifyIORef' fatals $ \(!i) -> (action: i, ())
_ -> action
printDeferredDiagnostics = liftIO $
forM_ [warnings, errors, fatals] $ \ref -> do
-- This IORef can leak when the dflags leaks, so let us always
- -- reset the content.
- actions <- atomicModifyIORef' ref $ \i -> ([], i)
+ -- reset the content. The lazy variant is used here as we want to force
+ -- this error if the IORef is ever accessed again, rather than now.
+ -- See #20981 for an issue which discusses this general issue.
+ let landmine = if debugIsOn then panic "withDeferredDiagnostics: use after free" else []
+ actions <- atomicModifyIORef ref $ \i -> (landmine, i)
sequence_ $ reverse actions
MC.bracket
@@ -2418,8 +2418,9 @@ cyclicModuleErr mss
cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe logger tmpfs dflags =
- unless (gopt Opt_KeepTmpFiles dflags) $
- liftIO $ cleanCurrentModuleTempFiles logger tmpfs
+ if gopt Opt_KeepTmpFiles dflags
+ then liftIO $ keepCurrentModuleTempFiles logger tmpfs
+ else liftIO $ cleanCurrentModuleTempFiles logger tmpfs
addDepsToHscEnv :: [HomeModInfo] -> HscEnv -> HscEnv
=====================================
compiler/GHC/Utils/TmpFs.hs
=====================================
@@ -13,6 +13,7 @@ module GHC.Utils.TmpFs
, cleanTempDirs
, cleanTempFiles
, cleanCurrentModuleTempFiles
+ , keepCurrentModuleTempFiles
, addFilesToClean
, changeTempFilesLifetime
, newTempName
@@ -172,6 +173,32 @@ cleanTempFiles logger tmpfs
, Set.toList cm_paths ++ Set.toList gs_paths)
remove to_delete
+-- | Keep all the paths in @tmp_files_to_clean@ and @tmp_subdirs_to_clean@
+-- that have lifetime TFL_CurrentModule. This function is used when `-keep-tmp-files` is
+-- used in an OPTIONS_GHC pragma.
+-- This function removes the temporary file from the TmpFs so we no longer remove
+-- it at the env when cleanTempFiles is called.
+keepCurrentModuleTempFiles :: HasCallStack => Logger -> TmpFs -> IO ()
+keepCurrentModuleTempFiles logger tmpfs
+ = mask_
+ $ do to_keep_files <- keep (tmp_files_to_clean tmpfs)
+ to_keep_subdirs <- keep (tmp_subdirs_to_clean tmpfs)
+ -- Remove any folders which contain any files we want to keep from the
+ -- directories we are tracking. A new temporary directory will be created
+ -- the next time a temporary file is needed (by perhaps another module).
+ keepDirs (to_keep_files ++ to_keep_subdirs) (tmp_dirs_to_clean tmpfs)
+ where
+ keepDirs keeps ref = do
+ let keep_dirs = Set.fromList (map takeDirectory keeps)
+ atomicModifyIORef' ref $ \m -> (Map.filter (\fp -> fp `Set.notMember` keep_dirs) m, ())
+
+ keep ref = do
+ to_keep <- atomicModifyIORef' ref $
+ \ptc at PathsToClean{ptcCurrentModule = cm_paths} ->
+ (ptc {ptcCurrentModule = Set.empty}, Set.toList cm_paths)
+ debugTraceMsg logger 2 (text "Keeping:" <+> hsep (map text to_keep))
+ return to_keep
+
-- | Delete all paths in @tmp_files_to_clean@ and @tmp_subdirs_to_clean@
-- That have lifetime TFL_CurrentModule.
-- If a file must be cleaned eventually, but must survive a
=====================================
testsuite/tests/driver/Makefile
=====================================
@@ -792,4 +792,21 @@ T22669:
! test -f T22669.o-boot
+T23339:
+ $(RM) T23339.hi
+ $(RM) T23339$(OBJSUFFIX)
+ $(RM) -rf "$(PWD)/tmp"
+ mkdir -p tmp
+ TMPDIR="$(PWD)/tmp" "$(TEST_HC)" $(TEST_HC_OPTS) -v0 T23339.hs
+ find . -name "*.c" -exec cat {} \; | grep "init__ip_init"
+
+T23339B:
+ $(RM) T23339.hi
+ $(RM) T23339$(OBJSUFFIX)
+ $(RM) -rf "$(PWD)/tmp"
+ mkdir -p tmp
+ TMPDIR="$(PWD)/tmp" "$(TEST_HC)" $(TEST_HC_OPTS) -v0 T23339B.hs -finfo-table-map
+ # Check that the file is kept and is the right one
+ find . -name "*.c" -exec cat {} \; | grep "init__ip_init"
+
=====================================
testsuite/tests/driver/T23339.hs
=====================================
@@ -0,0 +1,4 @@
+{-# OPTIONS_GHC -keep-tmp-files -finfo-table-map #-}
+module T23339 where
+
+defn = id "T23339"
=====================================
testsuite/tests/driver/T23339.stdout
=====================================
@@ -0,0 +1 @@
+void T23339_init__ip_init (void)
=====================================
testsuite/tests/driver/T23339B.hs
=====================================
@@ -0,0 +1,5 @@
+module T23339B where
+
+import T23339
+
+qux = id "abc"
=====================================
testsuite/tests/driver/T23339B.stdout
=====================================
@@ -0,0 +1 @@
+void T23339_init__ip_init (void)
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -320,3 +320,5 @@ test('T22044', normal, makefile_test, [])
test('T22048', [only_ways(['normal']), grep_errmsg("_rule")], compile, ["-O -fomit-interface-pragmas -ddump-simpl"])
test('T21722', normal, compile_fail, ['-fno-show-error-context'])
test('T22669', js_skip, makefile_test, [])
+test('T23339', js_skip, makefile_test, [])
+test('T23339B', [extra_files(['T23339.hs']), js_skip], makefile_test, [])
=====================================
testsuite/tests/ghci/prog018/prog018.stdout
=====================================
@@ -19,4 +19,7 @@ C.hs:6:7: error: [GHC-88464]
Variable not in scope: variableNotInScope :: ()
Failed, two modules loaded.
[3 of 3] Compiling C ( C.hs, interpreted )
+
+C.hs:6:7: error: [GHC-88464]
+ Variable not in scope: variableNotInScope :: ()
Failed, two modules loaded.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/90045770e4b744ac5793dce0aafd651677378265...384c9a2f0ce460d2f167f2dfc9fe6d823db580e4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/90045770e4b744ac5793dce0aafd651677378265...384c9a2f0ce460d2f167f2dfc9fe6d823db580e4
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230504/f04c933e/attachment-0001.html>
More information about the ghc-commits
mailing list