[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Drop `preloadClosure` from `UnitState`

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: b5d7db73 by fendor at 2026-06-15T07:25:31-04:00 Drop `preloadClosure` from `UnitState` It is always hard-coded to the same value. Backpack Unit instantiation isn't using it any more. Allows us to simplify the API and get rid of `improveUnit`. - - - - - c74424c6 by ARATA Mizuki at 2026-06-15T07:25:37-04:00 RISC-V NCG: Zero-extend the result of castFloatToWord32 According to the ISA manual, FMV.X.W sign-extends the result. We need to truncate the result to avoid creating an exotic Word32 value. Fixes #27300 - - - - - 8bf2acba by ARATA Mizuki at 2026-06-15T07:25:37-04:00 RISC-V NCG: Treat d28-d31 (ft8-ft11) as caller-saved According to the calling convention, the registers d28-d31 (ft8-ft11) are caller-saved. Fixes #27306 - - - - - f28947ed by ARATA Mizuki at 2026-06-15T07:25:37-04:00 RISC-V NCG: Set rounding mode when emitting `truncate` If we omit the rounding mode for `fcvt`, `dyn` will be used. We do not want that for `truncate`, so we set `rtz`. In other places, we set `rne` because we do not use the dynamic rounding mode. Fixes #27303 - - - - - 4bb7a7be by Zubin Duggal at 2026-06-15T07:25:38-04:00 rts: fix validate build with gcc 16. `__attribute__((regparm(1)))` is ignored on x86_64 and now gcc warns that it is ignored: rts/sm/Evac.h:35:1: error: error: ‘regparm’ attribute ignored [-Werror=attributes] See https://gcc.gnu.org/git/?p=gcc.git;a=commit;h=ccead81bbc39668376eb5cf47066ac... Fixes #27366 - - - - - 14 changed files: - + changelog.d/T27308 - compiler/GHC/CmmToAsm/RV64/CodeGen.hs - compiler/GHC/CmmToAsm/RV64/Instr.hs - compiler/GHC/CmmToAsm/RV64/Ppr.hs - compiler/GHC/CmmToAsm/RV64/Regs.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Unit.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/Types.hs - rts/sm/Evac.h - testsuite/tests/codeGen/should_run/T16617.hs - testsuite/tests/codeGen/should_run/T16617.stdout Changes: ===================================== changelog.d/T27308 ===================================== @@ -0,0 +1,10 @@ +section: compiler +synopsis: Drop `preloadClosure` from `UnitState` +issues: #27308 +mrs: !16108 + +description: { + Drop `preloadClosure` from `UnitState` as it is always set to the empty set. + This allows to simplify the `UnitState` and related functions. +} + ===================================== compiler/GHC/CmmToAsm/RV64/CodeGen.hs ===================================== @@ -718,7 +718,7 @@ getRegister' config plat expr = ( \dst -> code `appOL` code_x - `snocOL` annExpr expr (FCVT IntToFloat (OpReg to dst) (OpReg from reg_x)) -- (Signed ConVerT Float) + `snocOL` annExpr expr (FCVT IntToFloat (OpReg to dst) (OpReg from reg_x) Rne) -- (Signed ConVerT Float) ) MO_SF_Round from to -> pure @@ -726,7 +726,7 @@ getRegister' config plat expr = (floatFormat to) ( \dst -> code - `snocOL` annExpr expr (FCVT IntToFloat (OpReg to dst) (OpReg from reg)) -- (Signed ConVerT Float) + `snocOL` annExpr expr (FCVT IntToFloat (OpReg to dst) (OpReg from reg) Rne) -- (Signed ConVerT Float) ) -- TODO: Can this case happen? MO_FS_Truncate from to @@ -738,7 +738,7 @@ getRegister' config plat expr = code `snocOL` -- W32 is the smallest width to convert to. Decrease width afterwards. - annExpr expr (FCVT FloatToInt (OpReg W32 dst) (OpReg from reg)) + annExpr expr (FCVT FloatToInt (OpReg W32 dst) (OpReg from reg) Rtz) `appOL` signExtendAdjustPrecission W32 to dst dst -- (float convert (-> zero) signed) ) MO_FS_Truncate from to -> @@ -747,7 +747,7 @@ getRegister' config plat expr = (intFormat to) ( \dst -> code - `snocOL` annExpr expr (FCVT FloatToInt (OpReg to dst) (OpReg from reg)) + `snocOL` annExpr expr (FCVT FloatToInt (OpReg to dst) (OpReg from reg) Rtz) `appOL` truncateReg from to dst -- (float convert (-> zero) signed) ) MO_UU_Conv from to @@ -769,9 +769,18 @@ getRegister' config plat expr = `appOL` truncateReg from to dst ) MO_SS_Conv from to -> ss_conv from to reg code - MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` annExpr e (FCVT FloatToFloat (OpReg to dst) (OpReg from reg))) + MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` annExpr e (FCVT FloatToFloat (OpReg to dst) (OpReg from reg) Rne)) MO_WF_Bitcast w -> return $ Any (floatFormat w) (\dst -> code `snocOL` MOV (OpReg w dst) (OpReg w reg)) - MO_FW_Bitcast w -> return $ Any (intFormat w) (\dst -> code `snocOL` MOV (OpReg w dst) (OpReg w reg)) + MO_FW_Bitcast w -> + return + $ Any + (intFormat w) + ( \dst -> + code + `snocOL` MOV (OpReg w dst) (OpReg w reg) + -- FMV.X.W sign-extends the value, so truncate the result + `appOL` truncateReg W64 w dst + ) -- Conversions -- TODO: Duplication with MO_UU_Conv ===================================== compiler/GHC/CmmToAsm/RV64/Instr.hs ===================================== @@ -106,7 +106,7 @@ regUsageOfInstr platform instr = case instr of LDR _ dst src -> usage (regOp src, regOp dst) LDRU _ dst src -> usage (regOp src, regOp dst) FENCE _ _ -> usage ([], []) - FCVT _variant dst src -> usage (regOp src, regOp dst) + FCVT _variant dst src _rm -> usage (regOp src, regOp dst) FABS dst src -> usage (regOp src, regOp dst) FMIN dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) FMAX dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) @@ -165,6 +165,7 @@ callerSavedRegisters = ++ map regSingle [t3RegNo .. t6RegNo] ++ map regSingle [ft0RegNo .. ft7RegNo] ++ map regSingle [fa0RegNo .. fa7RegNo] + ++ map regSingle [ft8RegNo .. ft11RegNo] -- | Apply a given mapping to all the register references in this instruction. patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr @@ -205,7 +206,7 @@ patchRegsOfInstr instr env = case instr of LDR f o1 o2 -> LDR f (patchOp o1) (patchOp o2) LDRU f o1 o2 -> LDRU f (patchOp o1) (patchOp o2) FENCE o1 o2 -> FENCE o1 o2 - FCVT variant o1 o2 -> FCVT variant (patchOp o1) (patchOp o2) + FCVT variant o1 o2 rm -> FCVT variant (patchOp o1) (patchOp o2) rm FABS o1 o2 -> FABS (patchOp o1) (patchOp o2) FMIN o1 o2 o3 -> FMIN (patchOp o1) (patchOp o2) (patchOp o3) FMAX o1 o2 o3 -> FMAX (patchOp o1) (patchOp o2) (patchOp o3) @@ -612,7 +613,7 @@ data Instr -- Memory barrier. FENCE FenceType FenceType | -- | Floating point conversion - FCVT FcvtVariant Operand Operand + FCVT FcvtVariant Operand Operand RoundingMode | -- | Floating point ABSolute value FABS Operand Operand @@ -636,6 +637,21 @@ data FenceType = FenceRead | FenceWrite | FenceReadWrite -- | Variant of a floating point conversion instruction data FcvtVariant = FloatToFloat | IntToFloat | FloatToInt +-- | The rounding mode associated with an instruction +data RoundingMode + = -- | Round to nearest, ties to even + Rne + | -- | Round toward zero + Rtz + | -- | Round downward (toward negative infinity) + Rdn + | -- | Round upward (toward positive infinity) + Rup + | -- | Round to nearest, ties to max magnitude + Rmm + | -- | Dynamic rounding mode + Dyn + instrCon :: Instr -> String instrCon i = case i of ===================================== compiler/GHC/CmmToAsm/RV64/Ppr.hs ===================================== @@ -406,6 +406,17 @@ pprReg w r = case r of -- no support for widths > W64. | otherwise = pprPanic "Unsupported width in register (max is 64)" (ppr w <+> int i) +-- | Pretty print a rounding mode +-- +-- If the rounding mode is omitted, 'dyn' will be used. +pprRm :: IsLine doc => RoundingMode -> doc +pprRm Rne = text "rne" +pprRm Rtz = text "rtz" +pprRm Rdn = text "rdn" +pprRm Rup = text "rup" +pprRm Rmm = text "rmm" +pprRm Dyn = text "dyn" + -- | Single precission `Operand` (floating-point) isSingleOp :: Operand -> Bool isSingleOp (OpReg W32 _) = True @@ -643,25 +654,26 @@ pprInstr platform instr = case instr of LDRU FF64 o1 o2@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tfld") o1 o2 LDRU f o1 o2 -> pprPanic "Unsupported unsigned load" ((text . show) f <+> pprOp platform o1 <+> pprOp platform o2) FENCE r w -> line $ text "\tfence" <+> pprFenceType r <> char ',' <+> pprFenceType w - FCVT FloatToFloat o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.d") o1 o2 - FCVT FloatToFloat o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.s") o1 o2 - FCVT FloatToFloat o1 o2 -> + FCVT FloatToFloat o1@(OpReg W32 _) o2@(OpReg W64 _) rm -> op2rm (text "\tfcvt.s.d") o1 o2 rm + -- The assembler seems to be unhappy with explicit rounding mode on fcvt.d.s + FCVT FloatToFloat o1@(OpReg W64 _) o2@(OpReg W32 _) _rm -> op2 (text "\tfcvt.d.s") o1 o2 + FCVT FloatToFloat o1 o2 rm -> pprPanic "RV64.pprInstr - impossible float to float conversion" - $ line (pprOp platform o1 <> text "->" <> pprOp platform o2) - FCVT IntToFloat o1@(OpReg W32 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.s.w") o1 o2 - FCVT IntToFloat o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.l") o1 o2 - FCVT IntToFloat o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.w") o1 o2 - FCVT IntToFloat o1@(OpReg W64 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.d.l") o1 o2 - FCVT IntToFloat o1 o2 -> + $ line (pprOp platform o1 <> text "->" <> pprOp platform o2 <> text "," <> pprRm rm) + FCVT IntToFloat o1@(OpReg W32 _) o2@(OpReg W32 _) rm -> op2rm (text "\tfcvt.s.w") o1 o2 rm + FCVT IntToFloat o1@(OpReg W32 _) o2@(OpReg W64 _) rm -> op2rm (text "\tfcvt.s.l") o1 o2 rm + FCVT IntToFloat o1@(OpReg W64 _) o2@(OpReg W32 _) rm -> op2rm (text "\tfcvt.d.w") o1 o2 rm + FCVT IntToFloat o1@(OpReg W64 _) o2@(OpReg W64 _) rm -> op2rm (text "\tfcvt.d.l") o1 o2 rm + FCVT IntToFloat o1 o2 rm -> pprPanic "RV64.pprInstr - impossible integer to float conversion" - $ line (pprOp platform o1 <> text "->" <> pprOp platform o2) - FCVT FloatToInt o1@(OpReg W32 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.w.s") o1 o2 - FCVT FloatToInt o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.w.d") o1 o2 - FCVT FloatToInt o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.l.s") o1 o2 - FCVT FloatToInt o1@(OpReg W64 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.l.d") o1 o2 - FCVT FloatToInt o1 o2 -> + $ line (pprOp platform o1 <> text "->" <> pprOp platform o2 <> text "," <> pprRm rm) + FCVT FloatToInt o1@(OpReg W32 _) o2@(OpReg W32 _) rm -> op2rm (text "\tfcvt.w.s") o1 o2 rm + FCVT FloatToInt o1@(OpReg W32 _) o2@(OpReg W64 _) rm -> op2rm (text "\tfcvt.w.d") o1 o2 rm + FCVT FloatToInt o1@(OpReg W64 _) o2@(OpReg W32 _) rm -> op2rm (text "\tfcvt.l.s") o1 o2 rm + FCVT FloatToInt o1@(OpReg W64 _) o2@(OpReg W64 _) rm -> op2rm (text "\tfcvt.l.d") o1 o2 rm + FCVT FloatToInt o1 o2 rm -> pprPanic "RV64.pprInstr - impossible float to integer conversion" - $ line (pprOp platform o1 <> text "->" <> pprOp platform o2) + $ line (pprOp platform o1 <> text "->" <> pprOp platform o2 <> text "," <> pprRm rm) FABS o1 o2 | isSingleOp o2 -> op2 (text "\tfabs.s") o1 o2 FABS o1 o2 | isDoubleOp o2 -> op2 (text "\tfabs.d") o1 o2 FMIN o1 o2 o3 | isSingleOp o1 -> op3 (text "\tfmin.s") o1 o2 o3 @@ -678,6 +690,8 @@ pprInstr platform instr = case instr of instr -> panic $ "RV64.pprInstr - Unknown instruction: " ++ instrCon instr where op2 op o1 o2 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 + op2rm op o1 o2 Dyn = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 + op2rm op o1 o2 rm = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprRm rm op3 op o1 o2 o3 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 op4 op o1 o2 o3 o4 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 pprFenceType FenceRead = text "r" ===================================== compiler/GHC/CmmToAsm/RV64/Regs.hs ===================================== @@ -53,9 +53,14 @@ d7RegNo, ft7RegNo :: RegNo d7RegNo = 39 ft7RegNo = d7RegNo +d28RegNo, ft8RegNo :: RegNo +d28RegNo = 60 +ft8RegNo = d28RegNo + -- | Last floating point register. -d31RegNo :: RegNo +d31RegNo, ft11RegNo :: RegNo d31RegNo = 63 +ft11RegNo = d31RegNo a0RegNo, x10RegNo :: RegNo x10RegNo = 10 ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -242,7 +242,6 @@ withBkpSession cid insts deps session_type do_this = do -- Synthesize the flags , packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> let uid = unwireUnit unit_state - $ improveUnit unit_state $ renameHoleUnit unit_state (listToUFM insts) uid0 in ExposePackage (showSDoc dflags @@ -311,19 +310,16 @@ buildUnit session cid insts lunit = do -- The compilation dependencies are just the appropriately filled -- in unit IDs which must be compiled before we can compile. let hsubst = listToUFM insts - deps0 = map (renameHoleUnit (hsc_units hsc_env) hsubst) raw_deps + deps = map (renameHoleUnit (hsc_units hsc_env) hsubst) raw_deps -- Build dependencies OR make sure they make sense. BUT NOTE, -- we can only check the ones that are fully filled; the rest -- we have to defer until we've typechecked our local signature. -- TODO: work this into GHC.Driver.Make!! - forM_ (zip [1..] deps0) $ \(i, dep) -> + forM_ (zip [1..] deps) $ \(i, dep) -> case session of TcSession -> return () - _ -> compileInclude (length deps0) (i, dep) - - -- IMPROVE IT - let deps = map (improveUnit (hsc_units hsc_env)) deps0 + _ -> compileInclude (length deps) (i, dep) mb_old_eps <- case session of TcSession -> fmap Just getEpsGhc ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -914,13 +914,13 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do && 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) + r <- read_file hooks logger name_cache 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 + r2 <- load_dynamic_too_maybe hooks logger name_cache (setDynamicNow dflags) wanted_mod iface loc case r2 of @@ -936,20 +936,20 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do err -- | Check if we need to try the dynamic interface for -dynamic-too -load_dynamic_too_maybe :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags +load_dynamic_too_maybe :: Hooks -> Logger -> NameCache -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr MissingInterfaceError ()) -load_dynamic_too_maybe hooks logger name_cache unit_state dflags wanted_mod iface loc +load_dynamic_too_maybe hooks logger name_cache 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 hooks logger name_cache unit_state dflags wanted_mod iface loc + | gopt Opt_BuildDynamicToo dflags = load_dynamic_too hooks logger name_cache dflags wanted_mod iface loc | otherwise = return (Succeeded ()) -load_dynamic_too :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags +load_dynamic_too :: Hooks -> Logger -> NameCache -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr MissingInterfaceError ()) -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 +load_dynamic_too hooks logger name_cache dflags wanted_mod iface loc = do + read_file hooks logger name_cache dflags wanted_mod (ml_dyn_hi_file loc) >>= \case Succeeded (dynIface, _) | mi_mod_hash iface == mi_mod_hash dynIface -> return (Succeeded ()) @@ -963,10 +963,10 @@ load_dynamic_too hooks logger name_cache unit_state dflags wanted_mod iface loc -read_file :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags +read_file :: Hooks -> Logger -> NameCache -> DynFlags -> Module -> FilePath -> IO (MaybeErr ReadInterfaceError (ModIface, FilePath)) -read_file hooks logger name_cache unit_state dflags wanted_mod file_path = do +read_file hooks logger name_cache 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 @@ -975,7 +975,7 @@ read_file hooks logger name_cache unit_state dflags wanted_mod file_path = do case getModuleInstantiation wanted_mod of (_, Nothing) -> wanted_mod (_, Just indef_mod) -> - instModuleToModule unit_state + instModuleToModule (uninstantiateInstantiatedModule indef_mod) read_result <- readIface hooks logger dflags name_cache wanted_mod' file_path case read_result of ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -620,7 +620,7 @@ checkMergedSignatures hsc_env mod_summary self_recomp = do new_merged = case lookupUniqMap (requirementContext unit_state) (ms_mod_name mod_summary) of Nothing -> [] - Just r -> sort $ map (instModuleToModule unit_state) r + Just r -> sort $ map instModuleToModule r if old_merged == new_merged then up_to_date logger (text "signatures to merge in unchanged" $$ ppr new_merged) else return $ needsRecompileBecause SigsMergeChanged ===================================== compiler/GHC/Unit.hs ===================================== @@ -226,8 +226,8 @@ on-the-fly: A 'VirtUnit' may be indefinite or definite, it depends on whether some holes remain in the instantiated unit OR in the instantiating units (recursively). Having a fully instantiated (i.e. definite) virtual unit can lead to some issues -if there is a matching compiled unit in the preload closure. See Note [VirtUnit -to RealUnit improvement] +if there is a matching compiled unit in the preload closure. +See Note [VirtUnit to RealUnit improvement] Unit database and indefinite units ---------------------------------- @@ -314,7 +314,6 @@ field in the SDocContext to pretty-print. (i.e. GHC doesn't correctly call `pprWithUnitState` before pretty-printing a UnitId), that's what will be shown to the user so it's no big deal. - Note [VirtUnit to RealUnit improvement] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -332,6 +331,8 @@ same type-checking session, their names won't match (e.g. "abc:M.X" vs As we want them to match we just replace the virtual unit with the installed one: for some reason this is called "improvement". +HISTORICAL: + There is one last niggle: improvement based on the unit database means that we might end up developing on a unit that is not transitively depended upon by the units the user specified directly via command line @@ -340,6 +341,12 @@ instantiations are out of date. The solution is to only improve a unit id if the new unit id is part of the 'preloadClosure'; i.e., the closure of all the units which were explicitly specified. +NOTE: + +The 'preloadClosure' was completely unused, thus we removed it without +changing any of the tests. It doesn't seem to be necessary any more. +It is unclear at which exact point this became redundant. + Note [Representation of module/name variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In our ICFP'16, we use <A> to represent module holes, and {A.T} to represent ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -7,7 +7,6 @@ module GHC.Unit.State ( -- * Reading the package config, and processing cmdline args UnitState(..), - PreloadUnitClosure, UnitDatabase (..), UnitErr (..), emptyUnitState, @@ -29,7 +28,6 @@ module GHC.Unit.State ( lookupPackageName, resolvePackageImport, - improveUnit, searchPackageId, listVisibleModuleNames, lookupModuleInAllUnits, @@ -89,7 +87,6 @@ import GHC.Unit.Home import GHC.Types.Unique.FM import GHC.Types.Unique.DFM -import GHC.Types.Unique.Set import GHC.Types.Unique.DSet import GHC.Types.Unique.Map import GHC.Types.Unique @@ -268,8 +265,6 @@ originEmpty :: ModuleOrigin -> Bool originEmpty (ModOrigin Nothing [] [] False) = True originEmpty _ = False -type PreloadUnitClosure = UniqSet UnitId - -- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'. type VisibilityMap = UniqMap Unit UnitVisibility @@ -432,13 +427,6 @@ data UnitState = UnitState { -- may have the 'exposed' flag be 'False'.) unitInfoMap :: UnitInfoMap, - -- | The set of transitively reachable units according - -- to the explicitly provided command line arguments. - -- A fully instantiated VirtUnit may only be replaced by a RealUnit from - -- this set. - -- See Note [VirtUnit to RealUnit improvement] - preloadClosure :: PreloadUnitClosure, - -- | A mapping of 'PackageName' to 'UnitId'. If several units have the same -- package name (e.g. different instantiations), then we return one of them... -- This is used when users refer to packages in Backpack includes. @@ -491,7 +479,6 @@ data UnitState = UnitState { emptyUnitState :: UnitState emptyUnitState = UnitState { unitInfoMap = emptyUniqMap, - preloadClosure = emptyUniqSet, packageNameMap = emptyUFM, wireMap = emptyUniqMap, unwireMap = emptyUniqMap, @@ -517,7 +504,7 @@ type UnitInfoMap = UniqMap UnitId UnitInfo -- | Find the unit we know about with the given unit, if any lookupUnit :: UnitState -> Unit -> Maybe UnitInfo -lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs) (preloadClosure pkgs) +lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs) -- | A more specialized interface, which doesn't require a 'UnitState' (so it -- can be used while we're initializing 'DynFlags') @@ -525,16 +512,15 @@ lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs) (prelo -- Parameters: -- * a boolean specifying whether or not to look for on-the-fly renamed interfaces -- * a 'UnitInfoMap' --- * a 'PreloadUnitClosure' -lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo -lookupUnit' allowOnTheFlyInst pkg_map closure u = case u of +lookupUnit' :: Bool -> UnitInfoMap -> Unit -> Maybe UnitInfo +lookupUnit' allowOnTheFlyInst pkg_map u = case u of HoleUnit -> error "Hole unit" RealUnit i -> lookupUniqMap pkg_map (unDefinite i) VirtUnit i | allowOnTheFlyInst -> -- lookup UnitInfo of the indefinite unit to be instantiated and -- instantiate it on-the-fly - fmap (renameUnitInfo pkg_map closure (instUnitInsts i)) + fmap (renameUnitInfo pkg_map (instUnitInsts i)) (lookupUniqMap pkg_map (instUnitInstanceOf i)) | otherwise @@ -908,7 +894,6 @@ applyTrustFlag prec_map unusable pkgs flag = applyPackageFlag :: UnitPrecedenceMap -> UnitInfoMap - -> PreloadUnitClosure -> UnusableUnits -> Bool -- if False, if you expose a package, it implicitly hides -- any previously exposed packages with the same name @@ -917,10 +902,10 @@ applyPackageFlag -> PackageFlag -- flag to apply -> MaybeErr UnitErr VisibilityMap -- Now exposed -applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag = +applyPackageFlag prec_map pkg_map unusable no_hide_others pkgs vm flag = case flag of ExposePackage _ arg (ModRenaming b rns) -> - case findPackages prec_map pkg_map closure arg pkgs unusable of + case findPackages prec_map pkg_map arg pkgs unusable of Left ps -> Failed (PackageFlagErr flag ps) Right (p:_) -> Succeeded vm' where @@ -984,7 +969,7 @@ applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag = _ -> panic "applyPackageFlag" HidePackage str -> - case findPackages prec_map pkg_map closure (PackageArg str) pkgs unusable of + case findPackages prec_map pkg_map (PackageArg str) pkgs unusable of Left ps -> Failed (PackageFlagErr flag ps) Right ps -> Succeeded $ foldl' delFromUniqMap vm (map mkUnit ps) @@ -993,12 +978,11 @@ applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag = -- if the 'UnitArg' has a renaming associated with it. findPackages :: UnitPrecedenceMap -> UnitInfoMap - -> PreloadUnitClosure -> PackageArg -> [UnitInfo] -> UnusableUnits -> Either [(UnitInfo, UnusableUnitReason)] [UnitInfo] -findPackages prec_map pkg_map closure arg pkgs unusable +findPackages prec_map pkg_map arg pkgs unusable = let ps = mapMaybe (finder arg) pkgs in if null ps then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) @@ -1016,7 +1000,7 @@ findPackages prec_map pkg_map closure arg pkgs unusable -> Just p VirtUnit inst | instUnitInstanceOf inst == unitId p - -> Just (renameUnitInfo pkg_map closure (instUnitInsts inst) p) + -> Just (renameUnitInfo pkg_map (instUnitInsts inst) p) _ -> Nothing selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo] @@ -1031,10 +1015,10 @@ selectPackages prec_map arg pkgs unusable else Right (sortByPreference prec_map ps, rest) -- | Rename a 'UnitInfo' according to some module instantiation. -renameUnitInfo :: UnitInfoMap -> PreloadUnitClosure -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo -renameUnitInfo pkg_map closure insts conf = +renameUnitInfo :: UnitInfoMap -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo +renameUnitInfo pkg_map insts conf = let hsubst = listToUFM insts - smod = renameHoleModule' pkg_map closure hsubst + smod = renameHoleModule' pkg_map hsubst new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf) in conf { unitInstantiations = new_insts, @@ -1632,7 +1616,7 @@ mkUnitState logger cfg = do -- user tries to enable an unusable package, we should let them know. -- vis_map2 <- mayThrowUnitErr - $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable + $ foldM (applyPackageFlag prec_map prelim_pkg_db unusable (unitConfigHideAll cfg) pkgs1) vis_map1 other_flags @@ -1661,7 +1645,7 @@ mkUnitState logger cfg = do | otherwise = vis_map2 plugin_vis_map2 <- mayThrowUnitErr - $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable + $ foldM (applyPackageFlag prec_map prelim_pkg_db unusable hide_plugin_pkgs pkgs1) plugin_vis_map1 (reverse (unitConfigFlagsPlugins cfg)) @@ -1713,7 +1697,7 @@ mkUnitState logger cfg = do $ closeUnitDeps pkg_db $ zip (map toUnitId preload3) (repeat Nothing) - let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map + let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db vis_map mod_map2 = mkUnusableModuleNameProvidersMap unusable mod_map = mod_map2 `plusUniqMap` mod_map1 @@ -1723,9 +1707,8 @@ mkUnitState logger cfg = do , explicitUnits = explicit_pkgs , homeUnitDepends = home_unit_deps , unitInfoMap = pkg_db - , preloadClosure = emptyUniqSet , moduleNameProvidersMap = mod_map - , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map + , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db plugin_vis_map , packageNameMap = pkgname_map , wireMap = wired_map , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] @@ -1765,10 +1748,9 @@ mkModuleNameProvidersMap :: Logger -> UnitConfig -> UnitInfoMap - -> PreloadUnitClosure -> VisibilityMap -> ModuleNameProvidersMap -mkModuleNameProvidersMap logger cfg pkg_map closure vis_map = +mkModuleNameProvidersMap logger cfg pkg_map vis_map = -- What should we fold on? Both situations are awkward: -- -- * Folding on the visibility map means that we won't create @@ -1840,7 +1822,7 @@ mkModuleNameProvidersMap logger cfg pkg_map closure vis_map = hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] pk = mkUnit pkg - unit_lookup uid = lookupUnit' (unitConfigAllowVirtual cfg) pkg_map closure uid + unit_lookup uid = lookupUnit' (unitConfigAllowVirtual cfg) pkg_map uid `orElse` pprPanic "unit_lookup" (ppr uid) exposed_mods = unitExposedModules pkg @@ -2191,44 +2173,16 @@ fsPackageName info = fs where PackageName fs = unitPackageName info - --- | Given a fully instantiated 'InstantiatedUnit', improve it into a --- 'RealUnit' if we can find it in the package database. -improveUnit :: UnitState -> Unit -> Unit -improveUnit state u = improveUnit' (unitInfoMap state) (preloadClosure state) u - --- | Given a fully instantiated 'InstantiatedUnit', improve it into a --- 'RealUnit' if we can find it in the package database. -improveUnit' :: UnitInfoMap -> PreloadUnitClosure -> Unit -> Unit -improveUnit' _ _ uid@(RealUnit _) = uid -- short circuit -improveUnit' pkg_map closure uid = - -- Do NOT lookup indefinite ones, they won't be useful! - case lookupUnit' False pkg_map closure uid of - Nothing -> uid - Just pkg -> - -- Do NOT improve if the indefinite unit id is not - -- part of the closure unique set. See - -- Note [VirtUnit to RealUnit improvement] - if unitId pkg `elementOfUniqSet` closure - then mkUnit pkg - else uid - --- | Check the database to see if we already have an installed unit that --- corresponds to the given 'InstantiatedUnit'. --- --- Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged or --- references a matching installed unit. --- --- See Note [VirtUnit to RealUnit improvement] -instUnitToUnit :: UnitState -> InstantiatedUnit -> Unit -instUnitToUnit state iuid = +-- | Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged. +instUnitToUnit :: InstantiatedUnit -> Unit +instUnitToUnit iuid = -- NB: suppose that we want to compare the instantiated -- unit p[H=impl:H] against p+abcd (where p+abcd -- happens to be the existing, installed version of -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] -- VirtUnit, they won't compare equal; only -- after improvement will the equality hold. - improveUnit state $ VirtUnit iuid + VirtUnit iuid -- | Substitution on module variables, mapping module names to module @@ -2240,30 +2194,30 @@ type ShHoleSubst = ModuleNameEnv Module -- @p[A=\<A>]:B@ maps to @p[A=q():A]:B@ with @A=q():A@; -- similarly, @\<A>@ maps to @q():A@. renameHoleModule :: UnitState -> ShHoleSubst -> Module -> Module -renameHoleModule state = renameHoleModule' (unitInfoMap state) (preloadClosure state) +renameHoleModule state = renameHoleModule' (unitInfoMap state) -- | Substitutes holes in a 'Unit', suitable for renaming when -- an include occurs; see Note [Representation of module/name variables]. -- -- @p[A=\<A>]@ maps to @p[A=\<B>]@ with @A=\<B>@. renameHoleUnit :: UnitState -> ShHoleSubst -> Unit -> Unit -renameHoleUnit state = renameHoleUnit' (unitInfoMap state) (preloadClosure state) +renameHoleUnit state = renameHoleUnit' (unitInfoMap state) --- | Like 'renameHoleModule', but requires only 'ClosureUnitInfoMap' +-- | Like 'renameHoleModule', but requires only 'UnitInfoMap' -- so it can be used by "GHC.Unit.State". -renameHoleModule' :: UnitInfoMap -> PreloadUnitClosure -> ShHoleSubst -> Module -> Module -renameHoleModule' pkg_map closure env m +renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module +renameHoleModule' pkg_map env m | not (isHoleModule m) = - let uid = renameHoleUnit' pkg_map closure env (moduleUnit m) + let uid = renameHoleUnit' pkg_map env (moduleUnit m) in mkModule uid (moduleName m) | Just m' <- lookupUFM env (moduleName m) = m' -- NB m = <Blah>, that's what's in scope. | otherwise = m --- | Like 'renameHoleUnit, but requires only 'ClosureUnitInfoMap' +-- | Like 'renameHoleUnit', but requires only 'UnitInfoMap' -- so it can be used by "GHC.Unit.State". -renameHoleUnit' :: UnitInfoMap -> PreloadUnitClosure -> ShHoleSubst -> Unit -> Unit -renameHoleUnit' pkg_map closure env uid = +renameHoleUnit' :: UnitInfoMap -> ShHoleSubst -> Unit -> Unit +renameHoleUnit' pkg_map env uid = case uid of (VirtUnit InstantiatedUnit{ instUnitInstanceOf = cid @@ -2271,20 +2225,15 @@ renameHoleUnit' pkg_map closure env uid = , instUnitHoles = fh }) -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) then uid - -- Functorially apply the substitution to the instantiation, - -- then check the 'ClosureUnitInfoMap' to see if there is - -- a compiled version of this 'InstantiatedUnit' we can improve to. - -- See Note [VirtUnit to RealUnit improvement] - else improveUnit' pkg_map closure $ - mkVirtUnit cid - (map (\(k,v) -> (k, renameHoleModule' pkg_map closure env v)) insts) + else mkVirtUnit cid + (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) _ -> uid -- | Injects an 'InstantiatedModule' to 'Module' (see also -- 'instUnitToUnit'. -instModuleToModule :: UnitState -> InstantiatedModule -> Module -instModuleToModule pkgstate (Module iuid mod_name) = - mkModule (instUnitToUnit pkgstate iuid) mod_name +instModuleToModule :: InstantiatedModule -> Module +instModuleToModule (Module iuid mod_name) = + mkModule (instUnitToUnit iuid) mod_name -- | Print unit-ids with UnitInfo found in the given UnitState pprWithUnitState :: UnitState -> SDoc -> SDoc ===================================== compiler/GHC/Unit/Types.hs ===================================== @@ -250,9 +250,7 @@ data GenUnit uid -- -- This unit may be indefinite or not (i.e. with remaining holes or not). If it -- is definite, we don't know if it has already been compiled and installed in a --- database. Nevertheless, we have a mechanism called "improvement" to try to --- match a fully instantiated unit with existing compiled and installed units: --- see Note [VirtUnit to RealUnit improvement]. +-- database. -- -- An indefinite unit identifier pretty-prints to something like -- @p[H=<H>,A=aimpl:A>]@ (@p@ is the 'UnitId', and the ===================================== rts/sm/Evac.h ===================================== @@ -25,7 +25,9 @@ // registers EAX, EDX, and ECX instead of on the stack. Functions that // take a variable number of arguments will continue to be passed all of // their arguments on the stack. -#if defined(x86_64_HOST_ARCH) || defined(i386_HOST_ARCH) +// On x86-64 the attribute has no effect (the first argument is already +// passed in a register) and GCC 16 warns that it is ignored. +#if defined(i386_HOST_ARCH) #define REGPARM1 __attribute__((regparm(1))) #else #define REGPARM1 ===================================== testsuite/tests/codeGen/should_run/T16617.hs ===================================== @@ -1,10 +1,19 @@ import GHC.Float +{-# OPAQUE noinline #-} +noinline :: a -> a +noinline x = x + main :: IO () main = do -- As per #16617, Word32s should be non-negative print $ castFloatToWord32 (-1) print $ toInteger (castFloatToWord32 (-1)) > 0 + -- Disable constant folding; see #27300 + print $ castFloatToWord32 (noinline $ -1) + print $ toInteger (castFloatToWord32 (noinline $ -1)) > 0 -- For completeness, so should Word64s print $ castDoubleToWord64 (-1) print $ toInteger (castDoubleToWord64 (-1)) > 0 + print $ castDoubleToWord64 (noinline $ -1) + print $ toInteger (castDoubleToWord64 (noinline $ -1)) > 0 ===================================== testsuite/tests/codeGen/should_run/T16617.stdout ===================================== @@ -1,4 +1,8 @@ 3212836864 True +3212836864 +True +13830554455654793216 +True 13830554455654793216 True View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7e992dd0b4d71c823a6ce17c3f0e0c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7e992dd0b4d71c823a6ce17c3f0e0c... You're receiving this email because of your account on gitlab.haskell.org.