Ben Gamari pushed to branch wip/backports-9.14 at Glasgow Haskell Compiler / GHC Commits: 208763ab by Sylvain Henry at 2025-09-04T15:43:11-04:00 Driver: substitute virtual Prim module in --make mode too When we build ghc-internal with --make (e.g. with cabal-install), we need to be careful to substitute the virtual interface file for GHC.Internal.Prim: - after code generation (we generate code for an empty module, so we get an empty interface) - when we try to reload its .hi file (cherry picked from commit 6c78de2d6506bbbd9952ef884bdb60df8f8cf9f8) - - - - - 11 changed files: - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Recomp.hs - + testsuite/tests/driver/make-prim/GHC/Internal/Prim.hs - + testsuite/tests/driver/make-prim/Makefile - + testsuite/tests/driver/make-prim/Test.hs - + testsuite/tests/driver/make-prim/Test2.hs - + testsuite/tests/driver/make-prim/all.T Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -519,7 +519,7 @@ loopFixedModule key loc done = do -- part of the compiler. lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case Just iface -> return (M.Succeeded iface) - Nothing -> readIface (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc) + Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc) case read_result of M.Succeeded iface -> do -- Computer information about this node ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -1299,7 +1299,7 @@ hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_h -- when compiling gHC_PRIM without generating code (e.g. with -- Haddock), we still want the virtual interface in the cache if ms_mod summary == gHC_PRIM - then return $ HscUpdate (getGhcPrimIface hsc_env) + then return $ HscUpdate (getGhcPrimIface (hsc_hooks hsc_env)) else return $ HscUpdate iface @@ -1314,7 +1314,7 @@ hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_h -- when compiling gHC_PRIM without generating code (e.g. with -- Haddock), we still want the virtual interface in the cache if ms_mod summary == gHC_PRIM - then return $ HscUpdate (getGhcPrimIface hsc_env) + then return $ HscUpdate (getGhcPrimIface (hsc_hooks hsc_env)) else return $ HscUpdate iface {- ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -1616,7 +1616,7 @@ executeCompileNode k n !old_hmi hug mrehydrate_mods mni = do executeCompileNodeFixed hsc_env MakeEnv{diag_wrapper, env_messager} mod loc = wrapAction diag_wrapper hsc_env $ do forM_ env_messager $ \hscMessage -> hscMessage hsc_env (k, n) UpToDate (ModuleNode [] (ModuleNodeFixed mod loc)) - read_result <- readIface (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule mod) (ml_hi_file loc) + read_result <- readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule mod) (ml_hi_file loc) case read_result of M.Failed interface_err -> let mn = mnkModuleName mod ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -44,6 +44,7 @@ module GHC.Driver.Pipeline ( import GHC.Prelude +import GHC.Builtin.Names import GHC.Platform @@ -91,6 +92,7 @@ import GHC.Data.StringBuffer ( hPutStringBuffer ) import GHC.Data.Maybe ( expectJust ) import GHC.Iface.Make ( mkFullIface ) +import GHC.Iface.Load ( getGhcPrimIface ) import GHC.Runtime.Loader ( initializePlugins ) @@ -819,7 +821,13 @@ hscGenBackendPipeline pipe_env hsc_env mod_sum result = do let !linkable = Linkable part_time (ms_mod mod_sum) (NE.singleton (DotO final_object ModuleObject)) -- Add the object linkable to the potential bytecode linkable which was generated in HscBackend. return (mlinkable { homeMod_object = Just linkable }) - return (miface, final_linkable) + + -- when building ghc-internal with --make (e.g. with cabal-install), we want + -- the virtual interface for gHC_PRIM in the cache, not the empty one. + let miface_final + | ms_mod mod_sum == gHC_PRIM = getGhcPrimIface (hsc_hooks hsc_env) + | otherwise = miface + return (miface_final, final_linkable) asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe ObjFile) asPipeline use_cpp pipe_env hsc_env location input_fn = ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -895,6 +895,7 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do mhome_unit = hsc_home_unit_maybe hsc_env dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env + hooks = hsc_hooks hsc_env trace_if logger (sep [hsep [text "Reading", @@ -905,59 +906,51 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do ppr mod <> semi], nest 4 (text "reason:" <+> doc_str)]) - -- Check for GHC.Prim, and return its static interface - -- See Note [GHC.Prim] in primops.txt.pp. - -- TODO: make this check a function - if mod `installedModuleEq` gHC_PRIM - then do - let iface = getGhcPrimIface hsc_env - return (Succeeded (iface, panic "GHC.Prim ModLocation (findAndReadIface)")) - else do - -- Look for the file - mb_found <- liftIO (findExactModule hsc_env mod hi_boot_file) - case mb_found of - InstalledFound loc -> do - -- See Note [Home module load error] - if HUG.memberHugUnitId (moduleUnit mod) (hsc_HUG hsc_env) - && not (isOneShot (ghcMode dflags)) - then return (Failed (HomeModError mod loc)) - else do - r <- read_file logger name_cache unit_state dflags wanted_mod (ml_hi_file loc) - case r of - Failed err - -> return (Failed $ BadIfaceFile err) - Succeeded (iface,_fp) - -> do - r2 <- load_dynamic_too_maybe logger name_cache unit_state - (setDynamicNow dflags) wanted_mod - iface loc - case r2 of - Failed sdoc -> return (Failed sdoc) - Succeeded {} -> return $ Succeeded (iface, loc) - err -> do - trace_if logger (text "...not found") - return $ Failed $ cannotFindInterface - unit_state - mhome_unit - profile - (moduleName mod) - err + -- Look for the file + mb_found <- liftIO (findExactModule hsc_env mod hi_boot_file) + case mb_found of + InstalledFound loc -> do + -- See Note [Home module load error] + if HUG.memberHugUnitId (moduleUnit mod) (hsc_HUG hsc_env) + && not (isOneShot (ghcMode dflags)) + then return (Failed (HomeModError mod loc)) + else do + r <- read_file hooks logger name_cache unit_state dflags wanted_mod (ml_hi_file loc) + case r of + Failed err + -> return (Failed $ BadIfaceFile err) + Succeeded (iface,_fp) + -> do + r2 <- load_dynamic_too_maybe hooks logger name_cache unit_state + (setDynamicNow dflags) wanted_mod + iface loc + case r2 of + Failed sdoc -> return (Failed sdoc) + Succeeded {} -> return $ Succeeded (iface, loc) + err -> do + trace_if logger (text "...not found") + return $ Failed $ cannotFindInterface + unit_state + mhome_unit + profile + (moduleName mod) + err -- | Check if we need to try the dynamic interface for -dynamic-too -load_dynamic_too_maybe :: Logger -> NameCache -> UnitState -> DynFlags +load_dynamic_too_maybe :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr MissingInterfaceError ()) -load_dynamic_too_maybe logger name_cache unit_state dflags wanted_mod iface loc +load_dynamic_too_maybe hooks logger name_cache unit_state dflags wanted_mod iface loc -- Indefinite interfaces are ALWAYS non-dynamic. | not (moduleIsDefinite (mi_module iface)) = return (Succeeded ()) - | gopt Opt_BuildDynamicToo dflags = load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc + | gopt Opt_BuildDynamicToo dflags = load_dynamic_too hooks logger name_cache unit_state dflags wanted_mod iface loc | otherwise = return (Succeeded ()) -load_dynamic_too :: Logger -> NameCache -> UnitState -> DynFlags +load_dynamic_too :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr MissingInterfaceError ()) -load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc = do - read_file logger name_cache unit_state dflags wanted_mod (ml_dyn_hi_file loc) >>= \case +load_dynamic_too hooks logger name_cache unit_state dflags wanted_mod iface loc = do + read_file hooks logger name_cache unit_state dflags wanted_mod (ml_dyn_hi_file loc) >>= \case Succeeded (dynIface, _) | mi_mod_hash iface == mi_mod_hash dynIface -> return (Succeeded ()) @@ -971,10 +964,10 @@ load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc = do -read_file :: Logger -> NameCache -> UnitState -> DynFlags +read_file :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags -> Module -> FilePath -> IO (MaybeErr ReadInterfaceError (ModIface, FilePath)) -read_file logger name_cache unit_state dflags wanted_mod file_path = do +read_file hooks logger name_cache unit_state dflags wanted_mod file_path = do -- Figure out what is recorded in mi_module. If this is -- a fully definite interface, it'll match exactly, but @@ -985,7 +978,7 @@ read_file logger name_cache unit_state dflags wanted_mod file_path = do (_, Just indef_mod) -> instModuleToModule unit_state (uninstantiateInstantiatedModule indef_mod) - read_result <- readIface logger dflags name_cache wanted_mod' file_path + read_result <- readIface hooks logger dflags name_cache wanted_mod' file_path case read_result of Failed err -> return (Failed err) Succeeded iface -> return (Succeeded (iface, file_path)) @@ -1012,13 +1005,14 @@ flagsToIfCompression dflags -- Failed err <=> file not found, or unreadable, or illegible -- Succeeded iface <=> successfully found and parsed readIface - :: Logger + :: Hooks + -> Logger -> DynFlags -> NameCache -> Module -> FilePath -> IO (MaybeErr ReadInterfaceError ModIface) -readIface logger dflags name_cache wanted_mod file_path = do +readIface hooks logger dflags name_cache wanted_mod file_path = do trace_if logger (text "readIFace" <+> text file_path) let profile = targetProfile dflags res <- tryMost $ readBinIface profile name_cache CheckHiWay QuietBinIFace file_path @@ -1028,9 +1022,14 @@ readIface logger dflags name_cache wanted_mod file_path = do -- critical for correctness of recompilation checking -- (it lets us tell when -this-unit-id has changed.) | wanted_mod == actual_mod - -> return (Succeeded iface) + -> return (Succeeded final_iface) | otherwise -> return (Failed err) where + final_iface + -- Check for GHC.Prim, and return its static interface + -- See Note [GHC.Prim] in primops.txt.pp. + | wanted_mod == gHC_PRIM = getGhcPrimIface hooks + | otherwise = iface actual_mod = mi_module iface err = HiModuleNameMismatchWarn file_path wanted_mod actual_mod @@ -1245,8 +1244,8 @@ instance Outputable WhereFrom where -- This is a helper function that takes into account the hook allowing ghc-prim -- interface to be extended via the ghc-api. Afaik it was introduced for GHCJS -- so that it can add its own primitive types. -getGhcPrimIface :: HscEnv -> ModIface -getGhcPrimIface hsc_env = - case ghcPrimIfaceHook (hsc_hooks hsc_env) of +getGhcPrimIface :: Hooks -> ModIface +getGhcPrimIface hooks = + case ghcPrimIfaceHook hooks of Nothing -> ghcPrimIface Just h -> h ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -304,7 +304,7 @@ check_old_iface hsc_env mod_summary maybe_iface loadIface read_dflags iface_path = do let ncu = hsc_NC hsc_env - read_result <- readIface logger read_dflags ncu (ms_mod mod_summary) iface_path + read_result <- readIface (hsc_hooks hsc_env) logger read_dflags ncu (ms_mod mod_summary) iface_path case read_result of Failed err -> do let msg = readInterfaceErrorDiagnostic err ===================================== testsuite/tests/driver/make-prim/GHC/Internal/Prim.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Internal.Prim where + + ===================================== testsuite/tests/driver/make-prim/Makefile ===================================== @@ -0,0 +1,11 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +make-prim: + # build once to test the substitution of the virtual interface in --make + # mode with codegen + "$(TEST_HC)" $(TEST_HC_OPTS) --make Test.hs -this-unit-id ghc-internal -hide-all-packages -dno-typeable-binds -v0 + # build a different module (Test2) in --make mode to test the reloading + # of the GHC.Internal.Prim interface + "$(TEST_HC)" $(TEST_HC_OPTS) --make Test2.hs -this-unit-id ghc-internal -hide-all-packages -dno-typeable-binds -v0 ===================================== testsuite/tests/driver/make-prim/Test.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Test where + +import GHC.Internal.Prim + +foo :: Int# -> Int# +foo = notI# ===================================== testsuite/tests/driver/make-prim/Test2.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Test2 where + +import GHC.Internal.Prim + +foo :: Int# -> Int# +foo = notI# ===================================== testsuite/tests/driver/make-prim/all.T ===================================== @@ -0,0 +1 @@ +test('make-prim', [extra_files(['Test.hs','Test2.hs', 'GHC', 'GHC/Internal', 'GHC/Internal/Prim.hs'])], makefile_test, ['make-prim']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/208763abb678e61551ed4d750e4af99f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/208763abb678e61551ed4d750e4af99f... You're receiving this email because of your account on gitlab.haskell.org.