From 01e07ab13dcff69cd9a88ab56cc83f0a50ec63ae Mon Sep 17 00:00:00 2001 From: Ziyang Liu Date: Tue, 14 Sep 2021 23:57:24 -0700 Subject: Ensure .dyn_hi doesn't overwrite .hi This commit fixes the following bug: when `outputHi` is set, and both `.dyn_hi` and `.hi` are needed, both would be written to `outputHi`, causing `.dyn_hi` to overwrite `.hi`. This causes subsequent `readIface` to fail - "mismatched interface file profile tag (wanted "", got "dyn")" - triggering unnecessary rebuild. --- compiler/GHC/Driver/Main.hs | 6 +++--- compiler/GHC/Driver/Make.hs | 1 + compiler/GHC/Driver/Session.hs | 18 ++++++++++++------ docs/users_guide/separate_compilation.rst | 10 +++++++++- ghc/Main.hs | 5 +++++ testsuite/tests/driver/T20348/A.hs | 6 ++++++ testsuite/tests/driver/T20348/Makefile | 26 ++++++++++++++++++++++++++ testsuite/tests/driver/T20348/T20348.stdout | 3 +++ testsuite/tests/driver/T20348/all.T | 2 ++ 9 files changed, 67 insertions(+), 10 deletions(-) create mode 100644 testsuite/tests/driver/T20348/A.hs create mode 100644 testsuite/tests/driver/T20348/Makefile create mode 100644 testsuite/tests/driver/T20348/T20348.stdout create mode 100644 testsuite/tests/driver/T20348/all.T diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 788c2bce1f..647ce0bf26 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -961,15 +961,15 @@ hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do -- 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 - | Just name <- outputHi dflags + 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') + let !iface_name = buildIfName (hiSuf dflags') (dynamicNow dflags') profile = targetProfile dflags' in {-# SCC "writeIface" #-} diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index ef5ce36fef..bb15a919b9 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -1679,6 +1679,7 @@ enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife bcknd setOutputFile (Just o_file) $ setDynOutputFile (Just $ dynamicOutputFile dflags o_file) $ setOutputHi (Just hi_file) $ + setDynOutputHi (Just $ dynamicOutputHi dflags hi_file) $ dflags {backend = bcknd} } pure (ExtendedModSummary ms' bkp_deps) diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 9c64535c77..a6f1a50382 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -38,7 +38,7 @@ module GHC.Driver.Session ( xopt_FieldSelectors, lang_set, DynamicTooState(..), dynamicTooState, setDynamicNow, setDynamicTooFailed, - dynamicOutputFile, + dynamicOutputFile, dynamicOutputHi, sccProfilingEnabled, DynFlags(..), outputFile, hiSuf, objectSuf, ways, @@ -149,7 +149,7 @@ module GHC.Driver.Session ( initDynFlags, -- DynFlags -> IO DynFlags defaultFatalMessager, defaultFlushOut, - setOutputFile, setDynOutputFile, setOutputHi, + setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi, getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] getVerbFlags, @@ -539,6 +539,7 @@ data DynFlags = DynFlags { outputFile_ :: Maybe String, dynOutputFile_ :: Maybe String, outputHi :: Maybe String, + dynOutputHi :: Maybe String, dynLibLoader :: DynLibLoader, dynamicNow :: !Bool, -- ^ Indicate if we are now generating dynamic output @@ -1061,9 +1062,10 @@ setDynamicTooFailed dflags = -- | Compute the path of the dynamic object corresponding to an object file. dynamicOutputFile :: DynFlags -> FilePath -> FilePath -dynamicOutputFile dflags outputFile = dynOut outputFile - where - dynOut = flip addExtension (dynObjectSuf_ dflags) . dropExtension +dynamicOutputFile dflags outputFile = outputFile -<.> dynObjectSuf_ dflags + +dynamicOutputHi :: DynFlags -> FilePath -> FilePath +dynamicOutputHi dflags hi = hi -<.> dynHiSuf_ dflags ----------------------------------------------------------------------------- @@ -1182,6 +1184,7 @@ defaultDynFlags mySettings llvmConfig = outputFile_ = Nothing, dynOutputFile_ = Nothing, outputHi = Nothing, + dynOutputHi = Nothing, dynLibLoader = SystemDependent, dumpPrefix = Nothing, dumpPrefixForce = Nothing, @@ -1683,7 +1686,7 @@ setObjectDir, setHiDir, setHieDir, setStubDir, setDumpDir, setOutputDir, addCmdlineFramework, addHaddockOpts, addGhciScript, setInteractivePrint :: String -> DynFlags -> DynFlags -setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce +setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi, setDumpPrefixForce :: Maybe String -> DynFlags -> DynFlags setObjectDir f d = d { objectDir = Just f} @@ -1712,6 +1715,7 @@ setHcSuf f d = d { hcSuf = f} setOutputFile f d = d { outputFile_ = f} setDynOutputFile f d = d { dynOutputFile_ = f} setOutputHi f d = d { outputHi = f} +setDynOutputHi f d = d { dynOutputHi = f} parseUnitInsts :: String -> Instantiations parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of @@ -2203,6 +2207,8 @@ dynamic_flags_deps = [ (sepArg (setDynOutputFile . Just)) , make_ord_flag defGhcFlag "ohi" (hasArg (setOutputHi . Just )) + , make_ord_flag defGhcFlag "dynohi" + (hasArg (setDynOutputHi . Just )) , make_ord_flag defGhcFlag "osuf" (hasArg setObjectSuf) , make_ord_flag defGhcFlag "dynosuf" (hasArg setDynObjectSuf) , make_ord_flag defGhcFlag "hcsuf" (hasArg setHcSuf) diff --git a/docs/users_guide/separate_compilation.rst b/docs/users_guide/separate_compilation.rst index 64e6590942..b1f792d389 100644 --- a/docs/users_guide/separate_compilation.rst +++ b/docs/users_guide/separate_compilation.rst @@ -283,6 +283,14 @@ Redirecting the compilation output(s) to redirect the interface into the bit bucket: ``-ohi /dev/null``, for example. +.. ghc-flag:: -dynohi ⟨file⟩ + :shortdesc: set the filename in which to put the dynamic interface + :type: dynamic + :category: + + When using ``-dynamic-too``, option ``-dynohi`` ⟨file⟩ is the counterpart + of ``-ohi``. It redirects the dynamic interface output to ⟨file⟩. + .. ghc-flag:: -hidir ⟨dir⟩ :shortdesc: set directory for interface files :type: dynamic @@ -333,7 +341,7 @@ Redirecting the compilation output(s) :category: The ``-outputdir`` option is shorthand for the combination of - :ghc-flag:`-odir ⟨dir⟩`, :ghc-flag:`-hidir ⟨dir⟩`, :ghc-flag:`-hiedir ⟨dir⟩`, + :ghc-flag:`-odir ⟨dir⟩`, :ghc-flag:`-hidir ⟨dir⟩`, :ghc-flag:`-hiedir ⟨dir⟩`, :ghc-flag:`-stubdir ⟨dir⟩` and :ghc-flag:`-dumpdir ⟨dir⟩`. .. ghc-flag:: -osuf ⟨suffix⟩ diff --git a/ghc/Main.hs b/ghc/Main.hs index b9b1265f1e..b1c45e9cc4 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -321,6 +321,11 @@ checkOptions mode dflags srcs objs = do then throwGhcException (UsageError "-ohi can only be used when compiling a single source file") else do + if (isJust (dynOutputHi dflags) && + (isCompManagerMode mode || srcs `lengthExceeds` 1)) + then throwGhcException (UsageError "-dynohi can only be used when compiling a single source file") + else do + -- -o sanity checking if (srcs `lengthExceeds` 1 && isJust (outputFile dflags) && not (isLinkMode mode)) diff --git a/testsuite/tests/driver/T20348/A.hs b/testsuite/tests/driver/T20348/A.hs new file mode 100644 index 0000000000..39fa816b5e --- /dev/null +++ b/testsuite/tests/driver/T20348/A.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} + +module A where + +f :: Int -> Int +f x = x + 10 diff --git a/testsuite/tests/driver/T20348/Makefile b/testsuite/tests/driver/T20348/Makefile new file mode 100644 index 0000000000..e6903e4cc4 --- /dev/null +++ b/testsuite/tests/driver/T20348/Makefile @@ -0,0 +1,26 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +# Recompilation test for -fno-code -fwrite-interface with TemplateHaskell. + +checkExists = [ -f $1 ] || echo $1 missing + +clean: + rm -f *.o + rm -f *.hi + rm -f *.dyn_o + rm -f *.dyn_hi + +T20348: clean + # First run: should produce .hi, .o, .dyn_hi, .dyn_o files. + echo 'first run' + '$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fwrite-interface A.hs + $(call checkExists,A.hi) + $(call checkExists,A.o) + $(call checkExists,A.dyn_hi) + $(call checkExists,A.dyn_o) + + # Second run: should not recompile. + echo 'second run' + '$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fwrite-interface A.hs diff --git a/testsuite/tests/driver/T20348/T20348.stdout b/testsuite/tests/driver/T20348/T20348.stdout new file mode 100644 index 0000000000..1763145c31 --- /dev/null +++ b/testsuite/tests/driver/T20348/T20348.stdout @@ -0,0 +1,3 @@ +first run +[1 of 1] Compiling A ( A.hs, A.o, A.dyn_o ) +second run diff --git a/testsuite/tests/driver/T20348/all.T b/testsuite/tests/driver/T20348/all.T new file mode 100644 index 0000000000..cd888b0105 --- /dev/null +++ b/testsuite/tests/driver/T20348/all.T @@ -0,0 +1,2 @@ +test('T20348', [extra_files(['A.hs']), + when(opsys('mingw32'), skip)], makefile_test, []) -- cgit v1.2.1