Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 84a087d5 by Sylvain Henry at 2025-11-28T17:35:28-05:00 Fix PIC jump tables on Windows (#24016) Avoid overflows in jump tables by using a base label closer to the jump targets. See added Note [Jump tables] - - - - - 82db7042 by Zubin Duggal at 2025-11-28T17:36:10-05:00 rts/linker/PEi386: Copy strings before they are inserted into LoadedDllCache. The original strings are temporary and might be freed at an arbitrary point. Fixes #26613 - - - - - b419a523 by Ben Gamari at 2025-11-28T18:08:55-05:00 gitlab-ci: Run ghcup-metadata jobs on OpenCape runners This significantly reduces our egress traffic and makes the jobs significantly faster. - - - - - 5e0e1b15 by Matthew Pickering at 2025-11-28T18:08:56-05:00 Use 'OsPath' in getModificationTimeIfExists This part of the compiler is quite hot during recompilation checking in particular since the filepaths will be translated to a string. It is better to use the 'OsPath' native function, which turns out to be easy to do. - - - - - 80858c56 by Georgios Karachalias at 2025-11-28T18:09:03-05:00 Use OsPath in PkgDbRef and UnitDatabase, not FilePath - - - - - 22 changed files: - .gitlab-ci.yml - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToAsm/X86/Instr.hs - compiler/GHC/CmmToAsm/X86/Ppr.hs - compiler/GHC/Data/OsPath.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Utils/Misc.hs - compiler/GHC/Utils/Outputable.hs - docs/users_guide/phases.rst - rts/linker/PEi386.c - + testsuite/tests/codeGen/should_run/T24016.hs - + testsuite/tests/codeGen/should_run/T24016.stdout - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1184,6 +1184,10 @@ project-version: image: nixos/nix:2.25.2 dependencies: null tags: + # N.B. we use the OpenCape runners here since this job involves a significant + # amount of artifact fetching. This is much more efficient on these runners + # as they are near the GitLab box. + - opencape - x86_64-linux variables: BUILD_FLAVOUR: default ===================================== compiler/GHC/CmmToAsm/X86/CodeGen.hs ===================================== @@ -376,7 +376,7 @@ stmtToInstrs bid stmt = do --We try to arrange blocks such that the likely branch is the fallthrough --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here. CmmCondBranch arg true false _ -> genCondBranch bid true false arg - CmmSwitch arg ids -> genSwitch arg ids + CmmSwitch arg ids -> genSwitch arg ids bid CmmCall { cml_target = arg , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs) _ -> @@ -489,13 +489,6 @@ is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 where i64 = fromIntegral i :: Int64 --- | Convert a BlockId to some CmmStatic data -jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic -jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config)) -jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) - where blockLabel = blockLbl blockid - - -- ----------------------------------------------------------------------------- -- General things for putting together code sequences @@ -5375,11 +5368,52 @@ index (1), indexExpr = UU_Conv(indexOffset); // == 1::I64 See #21186. --} -genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock +Note [Jump tables] +~~~~~~~~~~~~~~~~~~ +The x86 backend has a virtual JMP_TBL instruction which payload can be used to +generate both the jump instruction and the jump table contents. `genSwitch` is +responsible for generating these JMP_TBL instructions. + +Depending on `-fPIC` flag and on the architecture, we generate the following +jump table variants: + + | Variant | Arch | Table's contents | Reference to the table | + |---------|--------|----------------------------------------|------------------------| + | PIC | Both | Relative offset: target_lbl - base_lbl | PIC | + | Non-PIC | 64-bit | Absolute: target_lbl | Non-PIC (rip-relative) | + | Non-PIC | 32-bit | Absolute: target_lbl | Non-PIC (absolute) | + +For the PIC variant, we store relative entries (`target_lbl - base_lbl`) in the +jump table. Using absolute entries with PIC would require target_lbl symbols to +be resolved at link time, hence to be global labels (currently they are local +labels). + +We use the block_id of the code containing the jump as `base_lbl`. It ensures +that target_lbl and base_lbl are close enough to each others, avoiding +overflows. + +Historical note: in the past we used the table label `table_lbl` as base_lbl. It +allowed the jumping code to only compute one global address (table_lbl) both to +read the table and to compute the target address. However: -genSwitch expr targets = do + * the table could be too far from the jump and on Windows which only + has 32-bit relative relocations (IMAGE_REL_AMD64_REL64 doesn't exist), + `dest_lbl - table_lbl` overflowed (see #24016) + + * Mac OS X/x86-64 linker was unable to handle `.quad L1 - L0` + relocations if L0 wasn't preceded by a non-anonymous label in its + section (which was the case with table_lbl). Hence we used to put the + jump table in the .text section in this case. + + +-} + +-- | Generate a JMP_TBL instruction +-- +-- See Note [Jump tables] +genSwitch :: CmmExpr -> SwitchTargets -> BlockId -> NatM InstrBlock +genSwitch expr targets bid = do config <- getConfig let platform = ncgPlatform config expr_w = cmmExprWidth platform expr @@ -5390,79 +5424,76 @@ genSwitch expr targets = do indexExpr = CmmMachOp (MO_UU_Conv expr_w (platformWordWidth platform)) [indexExpr0] - if ncgPIC config - then do - (reg,e_code) <- getNonClobberedReg indexExpr - -- getNonClobberedReg because it needs to survive across t_code - lbl <- getNewLabelNat - let is32bit = target32Bit platform - os = platformOS platform - -- Might want to use .rodata.<function we're in> instead, but as - -- long as it's something unique it'll work out since the - -- references to the jump table are in the appropriate section. - rosection = case os of - -- on Mac OS X/x86_64, put the jump table in the text section to - -- work around a limitation of the linker. - -- ld64 is unable to handle the relocations for - -- .quad L1 - L0 - -- if L0 is not preceded by a non-anonymous label in its section. - OSDarwin | not is32bit -> Section Text lbl - _ -> Section ReadOnlyData lbl - dynRef <- cmmMakeDynamicReference config DataReference lbl - (tableReg,t_code) <- getSomeReg $ dynRef - let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) - (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)) - - return $ e_code `appOL` t_code `appOL` toOL [ - ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg), - JMP_TBL (OpReg tableReg) ids rosection lbl - ] - else do - (reg,e_code) <- getSomeReg indexExpr - lbl <- getNewLabelNat - let is32bit = target32Bit platform - if is32bit - then let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl)) - jmp_code = JMP_TBL op ids (Section ReadOnlyData lbl) lbl - in return $ e_code `appOL` unitOL jmp_code - else do + + (offset, blockIds) = switchTargetsToTable targets + ids = map (fmap DestBlockId) blockIds + + is32bit = target32Bit platform + fmt = archWordFormat is32bit + + table_lbl <- getNewLabelNat + let bid_lbl = blockLbl bid + let table_section = Section ReadOnlyData table_lbl + + -- see Note [Jump tables] for a description of the following 3 variants. + if + | ncgPIC config -> do + -- PIC support: store relative offsets in the jump table to allow the code + -- to be relocated without updating the table. The table itself and the + -- block label used to make the relative labels absolute are read in a PIC + -- way (via cmmMakeDynamicReference). + (reg,e_code) <- getNonClobberedReg indexExpr -- getNonClobberedReg because it needs to survive across t_code and j_code + (tableReg,t_code) <- getNonClobberedReg =<< cmmMakeDynamicReference config DataReference table_lbl + (targetReg,j_code) <- getSomeReg =<< cmmMakeDynamicReference config DataReference bid_lbl + pure $ e_code `appOL` t_code `appOL` j_code `appOL` toOL + [ ADD fmt (OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))) + (OpReg targetReg) + , JMP_TBL (OpReg targetReg) ids table_section table_lbl (Just bid_lbl) + ] + + | not is32bit -> do + -- 64-bit non-PIC code + (reg,e_code) <- getSomeReg indexExpr + tableReg <- getNewRegNat (intFormat (platformWordWidth platform)) + targetReg <- getNewRegNat (intFormat (platformWordWidth platform)) + pure $ e_code `appOL` toOL -- See Note [%rip-relative addressing on x86-64]. - tableReg <- getNewRegNat (intFormat (platformWordWidth platform)) - targetReg <- getNewRegNat (intFormat (platformWordWidth platform)) - let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)) - fmt = archWordFormat is32bit - code = e_code `appOL` toOL - [ LEA fmt (OpAddr (AddrBaseIndex EABaseRip EAIndexNone (ImmCLbl lbl))) (OpReg tableReg) - , MOV fmt op (OpReg targetReg) - , JMP_TBL (OpReg targetReg) ids (Section ReadOnlyData lbl) lbl - ] - return code - where - (offset, blockIds) = switchTargetsToTable targets - ids = map (fmap DestBlockId) blockIds + [ LEA fmt (OpAddr (AddrBaseIndex EABaseRip EAIndexNone (ImmCLbl table_lbl))) (OpReg tableReg) + , MOV fmt (OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))) + (OpReg targetReg) + , JMP_TBL (OpReg targetReg) ids table_section table_lbl Nothing + ] + + | otherwise -> do + -- 32-bit non-PIC code is a straightforward jump to &table[entry]. + (reg,e_code) <- getSomeReg indexExpr + pure $ e_code `appOL` unitOL + ( JMP_TBL (OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl table_lbl))) + ids table_section table_lbl Nothing + ) generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr) -generateJumpTableForInstr config (JMP_TBL _ ids section lbl) - = let getBlockId (DestBlockId id) = id - getBlockId _ = panic "Non-Label target in Jump Table" - blockIds = map (fmap getBlockId) ids - in Just (createJumpTable config blockIds section lbl) -generateJumpTableForInstr _ _ = Nothing - -createJumpTable :: NCGConfig -> [Maybe BlockId] -> Section -> CLabel - -> GenCmmDecl (Alignment, RawCmmStatics) h g -createJumpTable config ids section lbl - = let jumpTable - | ncgPIC config = - let ww = ncgWordWidth config - jumpTableEntryRel Nothing - = CmmStaticLit (CmmInt 0 ww) - jumpTableEntryRel (Just blockid) - = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww) - where blockLabel = blockLbl blockid - in map jumpTableEntryRel ids - | otherwise = map (jumpTableEntry config) ids - in CmmData section (mkAlignment 1, CmmStaticsRaw lbl jumpTable) +generateJumpTableForInstr config = \case + JMP_TBL _ ids section table_lbl mrel_lbl -> + let getBlockId (DestBlockId id) = id + getBlockId _ = panic "Non-Label target in Jump Table" + block_ids = map (fmap getBlockId) ids + + jumpTable = case mrel_lbl of + Nothing -> map mk_absolute block_ids -- absolute entries + Just rel_lbl -> map (mk_relative rel_lbl) block_ids -- offsets relative to rel_lbl + + mk_absolute = \case + Nothing -> CmmStaticLit (CmmInt 0 (ncgWordWidth config)) + Just blockid -> CmmStaticLit (CmmLabel (blockLbl blockid)) + + mk_relative rel_lbl = \case + Nothing -> CmmStaticLit (CmmInt 0 (ncgWordWidth config)) + Just blockid -> CmmStaticLit (CmmLabelDiffOff (blockLbl blockid) rel_lbl 0 (ncgWordWidth config)) + + in Just (CmmData section (mkAlignment 1, CmmStaticsRaw table_lbl jumpTable)) + + _ -> Nothing extractUnwindPoints :: [Instr] -> [UnwindPoint] extractUnwindPoints instrs = ===================================== compiler/GHC/CmmToAsm/X86/Instr.hs ===================================== @@ -252,6 +252,7 @@ data Instr [Maybe JumpDest] -- Targets of the jump table Section -- Data section jump table should be put in CLabel -- Label of jump table + !(Maybe CLabel) -- Label used to compute relative offsets. Otherwise we store absolute addresses. -- | X86 call instruction | CALL (Either Imm Reg) -- ^ Jump target [RegWithFormat] -- ^ Arguments (required for register allocation) @@ -486,7 +487,7 @@ regUsageOfInstr platform instr JXX _ _ -> mkRU [] [] JXX_GBL _ _ -> mkRU [] [] JMP op regs -> mkRU (use_R addrFmt op regs) [] - JMP_TBL op _ _ _ -> mkRU (use_R addrFmt op []) [] + JMP_TBL op _ _ _ _ -> mkRU (use_R addrFmt op []) [] CALL (Left _) params -> mkRU params (map mkFmt $ callClobberedRegs platform) CALL (Right reg) params -> mkRU (mk addrFmt reg:params) (map mkFmt $ callClobberedRegs platform) CLTD fmt -> mkRU [mk fmt eax] [mk fmt edx] @@ -812,7 +813,7 @@ patchRegsOfInstr platform instr env POP fmt op -> patch1 (POP fmt) op SETCC cond op -> patch1 (SETCC cond) op JMP op regs -> JMP (patchOp op) regs - JMP_TBL op ids s lbl -> JMP_TBL (patchOp op) ids s lbl + JMP_TBL op ids s tl jl -> JMP_TBL (patchOp op) ids s tl jl FMA3 fmt perm var x1 x2 x3 -> patch3 (FMA3 fmt perm var) x1 x2 x3 @@ -1016,9 +1017,9 @@ isJumpishInstr instr canFallthroughTo :: Instr -> BlockId -> Bool canFallthroughTo insn bid = case insn of - JXX _ target -> bid == target - JMP_TBL _ targets _ _ -> all isTargetBid targets - _ -> False + JXX _ target -> bid == target + JMP_TBL _ targets _ _ _ -> all isTargetBid targets + _ -> False where isTargetBid target = case target of Nothing -> True @@ -1031,9 +1032,9 @@ jumpDestsOfInstr jumpDestsOfInstr insn = case insn of - JXX _ id -> [id] - JMP_TBL _ ids _ _ -> [id | Just (DestBlockId id) <- ids] - _ -> [] + JXX _ id -> [id] + JMP_TBL _ ids _ _ _ -> [id | Just (DestBlockId id) <- ids] + _ -> [] patchJumpInstr @@ -1042,8 +1043,8 @@ patchJumpInstr patchJumpInstr insn patchF = case insn of JXX cc id -> JXX cc (patchF id) - JMP_TBL op ids section lbl - -> JMP_TBL op (map (fmap (patchJumpDest patchF)) ids) section lbl + JMP_TBL op ids section table_lbl rel_lbl + -> JMP_TBL op (map (fmap (patchJumpDest patchF)) ids) section table_lbl rel_lbl _ -> insn where patchJumpDest f (DestBlockId id) = DestBlockId (f id) @@ -1504,14 +1505,14 @@ shortcutJump fn insn = shortcutJump' fn (setEmpty :: LabelSet) insn Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id') Just (DestImm imm) -> shortcutJump' fn seen' (JXX_GBL cc imm) where seen' = setInsert id seen - shortcutJump' fn _ (JMP_TBL addr blocks section tblId) = + shortcutJump' fn _ (JMP_TBL addr blocks section table_lbl rel_lbl) = let updateBlock (Just (DestBlockId bid)) = case fn bid of Nothing -> Just (DestBlockId bid ) Just dest -> Just dest updateBlock dest = dest blocks' = map updateBlock blocks - in JMP_TBL addr blocks' section tblId + in JMP_TBL addr blocks' section table_lbl rel_lbl shortcutJump' _ _ other = other -- Here because it knows about JumpDest ===================================== compiler/GHC/CmmToAsm/X86/Ppr.hs ===================================== @@ -895,7 +895,7 @@ pprInstr platform i = case i of JMP op _ -> line $ text "\tjmp *" <> pprOperand platform (archWordFormat (target32Bit platform)) op - JMP_TBL op _ _ _ + JMP_TBL op _ _ _ _ -> pprInstr platform (JMP op []) CALL (Left imm) _ ===================================== compiler/GHC/Data/OsPath.hs ===================================== @@ -11,6 +11,15 @@ module GHC.Data.OsPath -- * Common utility functions , (</>) , (<.>) + , splitSearchPath + , isRelative + , dropTrailingPathSeparator + , takeDirectory + , isSuffixOf + , doesDirectoryExist + , doesFileExist + , getDirectoryContents + , createDirectoryIfMissing ) where @@ -20,6 +29,8 @@ import GHC.Utils.Misc (HasCallStack) import GHC.Utils.Panic (panic) import System.OsPath +import System.OsString (isSuffixOf) +import System.Directory.OsPath (doesDirectoryExist, doesFileExist, getDirectoryContents, createDirectoryIfMissing) import System.Directory.Internal (os) -- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed. ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -441,7 +441,7 @@ addUnit u = do Nothing -> panic "addUnit: called too early" Just dbs -> let newdb = UnitDatabase - { unitDatabasePath = "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")" + { unitDatabasePath = unsafeEncodeUtf $ "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")" , unitDatabaseUnits = [u] } in return (dbs ++ [newdb]) -- added at the end because ordering matters @@ -789,8 +789,8 @@ summariseRequirement pn mod_name = do env <- getBkpEnv src_hash <- liftIO $ getFileHash (bkp_filename env) - hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) - hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) + hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file_ospath location) + hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file_ospath location) let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1) let fc = hsc_FC hsc_env @@ -875,8 +875,8 @@ hsModuleToModSummary home_keys pn hsc_src modname HsSrcFile -> os "hs") hsc_src -- This duplicates a pile of logic in GHC.Driver.Make - hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) - hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) + hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file_ospath location) + hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file_ospath location) -- Also copied from 'getImports' let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps ===================================== compiler/GHC/Driver/CodeOutput.hs ===================================== @@ -38,7 +38,7 @@ import GHC.Driver.LlvmConfigCache (LlvmConfigCache) import GHC.Driver.Ppr import GHC.Driver.Backend -import GHC.Data.OsPath +import GHC.Data.OsPath qualified as OsPath import qualified GHC.Data.ShortText as ST import GHC.Data.Stream ( liftIO ) import qualified GHC.Data.Stream as Stream @@ -61,8 +61,6 @@ import GHC.Types.ForeignStubs import GHC.Types.Unique.DSM import GHC.Types.Unique.Supply ( UniqueTag(..) ) -import System.Directory -import System.FilePath import System.IO import Data.Set (Set) import qualified Data.Set as Set @@ -321,10 +319,9 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs stub_h_file_exists <- case mkStubPaths (initFinderOpts dflags) (moduleName mod) location of Nothing -> pure False - Just path -> do - let stub_h = unsafeDecodeUtf path - createDirectoryIfMissing True (takeDirectory stub_h) - outputForeignStubs_help stub_h stub_h_output_w + Just stub_h -> do + OsPath.createDirectoryIfMissing True (OsPath.takeDirectory stub_h) + outputForeignStubs_help (OsPath.unsafeDecodeUtf stub_h) stub_h_output_w ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr putDumpFileMaybe logger Opt_D_dump_foreign ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -1265,7 +1265,7 @@ checkSummaryHash | ms_hs_hash old_summary == src_hash && not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do -- update the object-file timestamp - obj_timestamp <- modificationTimeIfExists (ml_obj_file location) + obj_timestamp <- modificationTimeIfExists (ml_obj_file_ospath location) -- We have to repopulate the Finder's cache for file targets -- because the file might not even be on the regular search path @@ -1277,8 +1277,8 @@ checkSummaryHash hsc_src = ms_hsc_src old_summary addModuleToFinder fc mod location hsc_src - hi_timestamp <- modificationTimeIfExists (ml_hi_file location) - hie_timestamp <- modificationTimeIfExists (ml_hie_file location) + hi_timestamp <- modificationTimeIfExists (ml_hi_file_ospath location) + hie_timestamp <- modificationTimeIfExists (ml_hie_file_ospath location) return $ Right ( old_summary @@ -1482,11 +1482,11 @@ data MakeNewModSummary makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary makeNewModSummary hsc_env MakeNewModSummary{..} = do let PreprocessedImports{..} = nms_preimps - obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location) - dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file nms_location) - hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location) - hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location) - bytecode_timestamp <- modificationTimeIfExists (ml_bytecode_file nms_location) + obj_timestamp <- modificationTimeIfExists (ml_obj_file_ospath nms_location) + dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file_ospath nms_location) + hi_timestamp <- modificationTimeIfExists (ml_hi_file_ospath nms_location) + hie_timestamp <- modificationTimeIfExists (ml_hie_file_ospath nms_location) + bytecode_timestamp <- modificationTimeIfExists (ml_bytecode_file_ospath nms_location) extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -101,6 +101,7 @@ import GHC.Core.Unfold import GHC.Data.Bool import GHC.Data.EnumSet (EnumSet) import GHC.Data.Maybe +import GHC.Data.OsPath ( OsPath ) import GHC.Builtin.Names ( mAIN_NAME ) import GHC.Driver.Backend import GHC.Driver.Flags @@ -953,7 +954,7 @@ setDynamicNow dflags0 = data PkgDbRef = GlobalPkgDb | UserPkgDb - | PkgDbPath FilePath + | PkgDbPath OsPath deriving Eq ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -1091,7 +1091,7 @@ loadIfaceByteCode hsc_env iface location type_env = linkable $ pure $ DotGBC bco linkable parts = do - if_time <- modificationTimeIfExists (ml_hi_file location) + if_time <- modificationTimeIfExists (ml_hi_file_ospath location) time <- maybe getCurrentTime pure if_time return $! Linkable time (mi_module iface) parts @@ -1112,7 +1112,7 @@ loadIfaceByteCodeLazy hsc_env iface location type_env = linkable $ NE.singleton (DotGBC bco) linkable parts = do - if_time <- modificationTimeIfExists (ml_hi_file location) + if_time <- modificationTimeIfExists (ml_hi_file_ospath location) time <- maybe getCurrentTime pure if_time return $!Linkable time (mi_module iface) parts @@ -2240,7 +2240,7 @@ generateAndWriteByteCodeLinkable hsc_env cgguts mod_location = do -- Either, get the same time as the .gbc file if it exists, or just the current time. -- It's important the time of the linkable matches the time of the .gbc file for recompilation -- checking. - bco_time <- maybe getCurrentTime pure =<< modificationTimeIfExists (ml_bytecode_file mod_location) + bco_time <- maybe getCurrentTime pure =<< modificationTimeIfExists (ml_bytecode_file_ospath mod_location) return $ mkModuleByteCodeLinkable bco_time bco_object mkModuleByteCode :: HscEnv -> Module -> ModLocation -> CgInteractiveGuts -> IO ModuleByteCode ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -730,17 +730,17 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do -- the object file for one module.) -- Note the nasty duplication with the same computation in compileFile above location <- mkOneShotModLocation pipe_env dflags src_flavour mod_name - let o_file = ml_obj_file location -- The real object file - hi_file = ml_hi_file location - hie_file = ml_hie_file location - dyn_o_file = ml_dyn_obj_file location + let o_file = ml_obj_file_ospath location -- The real object file + hi_file = ml_hi_file_ospath location + hie_file = ml_hie_file_ospath location + dyn_o_file = ml_dyn_obj_file_ospath location src_hash <- getFileHash (basename <.> suff) hi_date <- modificationTimeIfExists hi_file hie_date <- modificationTimeIfExists hie_file o_mod <- modificationTimeIfExists o_file dyn_o_mod <- modificationTimeIfExists dyn_o_file - bytecode_date <- modificationTimeIfExists (ml_bytecode_file location) + bytecode_date <- modificationTimeIfExists (ml_bytecode_file_ospath location) -- Tell the finder cache about this module mod <- do ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -300,6 +300,8 @@ import qualified Data.Set as Set import GHC.Types.Unique.Set import Data.Word import System.FilePath +import qualified GHC.Data.OsPath as OsPath + import Text.ParserCombinators.ReadP hiding (char) import Text.ParserCombinators.ReadP as R @@ -2071,7 +2073,7 @@ package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] package_flags_deps = [ ------- Packages ---------------------------------------------------- make_ord_flag defFlag "package-db" - (HasArg (addPkgDbRef . PkgDbPath)) + (HasArg (addPkgDbRef . PkgDbPath . OsPath.unsafeEncodeUtf)) , make_ord_flag defFlag "clear-package-db" (NoArg clearPkgDb) , make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgDb) , make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgDb) @@ -2081,7 +2083,7 @@ package_flags_deps = [ (NoArg (addPkgDbRef UserPkgDb)) -- backwards compat with GHC<=7.4 : , make_dep_flag defFlag "package-conf" - (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead" + (HasArg $ addPkgDbRef . PkgDbPath . OsPath.unsafeEncodeUtf) "Use -package-db instead" , make_dep_flag defFlag "no-user-package-conf" (NoArg removeUserPkgDb) "Use -no-user-package-db instead" , make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> @@ -3307,7 +3309,7 @@ parseEnvFile :: FilePath -> String -> DynP () parseEnvFile envfile = mapM_ parseEntry . lines where parseEntry str = case words str of - ("package-db": _) -> addPkgDbRef (PkgDbPath (envdir </> db)) + ("package-db": _) -> addPkgDbRef (PkgDbPath (OsPath.unsafeEncodeUtf (envdir </> db))) -- relative package dbs are interpreted relative to the env file where envdir = takeDirectory envfile db = drop 11 str ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -658,8 +658,9 @@ findWholeCoreBindings hsc_env mod = do findBytecodeLinkableMaybe :: HscEnv -> Module -> ModLocation -> IO (Maybe Linkable) findBytecodeLinkableMaybe hsc_env mod locn = do - let bytecode_fn = ml_bytecode_file locn - maybe_bytecode_time <- modificationTimeIfExists bytecode_fn + let bytecode_fn = ml_bytecode_file locn + bytecode_fn_os = ml_bytecode_file_ospath locn + maybe_bytecode_time <- modificationTimeIfExists bytecode_fn_os case maybe_bytecode_time of Nothing -> return Nothing Just bytecode_time -> do ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -63,7 +63,6 @@ import GHC.Types.SourceFile import GHC.Fingerprint import Data.IORef -import System.Directory.OsPath import Control.Applicative ((<|>)) import Control.Monad import Data.Time @@ -826,7 +825,7 @@ mkStubPaths fopts mod location = do findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable) findObjectLinkableMaybe mod locn = do let obj_fn = ml_obj_file locn - maybe_obj_time <- modificationTimeIfExists obj_fn + maybe_obj_time <- modificationTimeIfExists (ml_obj_file_ospath locn) case maybe_obj_time of Nothing -> return Nothing Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -101,6 +101,8 @@ import GHC.Data.Maybe import System.Environment ( getEnv ) import GHC.Data.FastString +import GHC.Data.OsPath ( OsPath ) +import qualified GHC.Data.OsPath as OsPath import qualified GHC.Data.ShortText as ST import GHC.Utils.Logger import GHC.Utils.Error @@ -111,7 +113,7 @@ import System.FilePath as FilePath import Control.Monad import Data.Graph (stronglyConnComp, SCC(..)) import Data.Char ( toUpper ) -import Data.List ( intersperse, partition, sortBy, isSuffixOf, sortOn ) +import Data.List ( intersperse, partition, sortBy, sortOn ) import Data.Set (Set) import Data.Monoid (First(..)) import qualified Data.Semigroup as Semigroup @@ -407,7 +409,7 @@ initUnitConfig dflags cached_dbs home_units = where offsetPackageDb :: Maybe FilePath -> PackageDBFlag -> PackageDBFlag - offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | isRelative p = PackageDB (PkgDbPath (offset </> p)) + offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | OsPath.isRelative p = PackageDB (PkgDbPath (OsPath.unsafeEncodeUtf offset OsPath.</> p)) offsetPackageDb _ p = p @@ -502,12 +504,12 @@ emptyUnitState = UnitState { -- | Unit database data UnitDatabase unit = UnitDatabase - { unitDatabasePath :: FilePath + { unitDatabasePath :: OsPath , unitDatabaseUnits :: [GenUnitInfo unit] } instance Outputable u => Outputable (UnitDatabase u) where - ppr (UnitDatabase fp _u) = text "DB:" <+> text fp + ppr (UnitDatabase fp _u) = text "DB:" <+> ppr fp type UnitInfoMap = UniqMap UnitId UnitInfo @@ -722,9 +724,9 @@ getUnitDbRefs cfg = do Left _ -> system_conf_refs Right path | Just (xs, x) <- snocView path, isSearchPathSeparator x - -> map PkgDbPath (splitSearchPath xs) ++ system_conf_refs + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs | otherwise - -> map PkgDbPath (splitSearchPath path) + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path)) -- Apply the package DB-related flags from the command line to get the -- final list of package DBs. @@ -753,24 +755,24 @@ getUnitDbRefs cfg = do -- NB: This logic is reimplemented in Cabal, so if you change it, -- make sure you update Cabal. (Or, better yet, dump it in the -- compiler info so Cabal can use the info.) -resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe FilePath) -resolveUnitDatabase cfg GlobalPkgDb = return $ Just (unitConfigGlobalDB cfg) +resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe OsPath) +resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitConfigGlobalDB cfg resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOS cfg) let pkgconf = dir </> unitConfigDBName cfg exist <- tryMaybeT $ doesDirectoryExist pkgconf - if exist then return pkgconf else mzero + if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero resolveUnitDatabase _ (PkgDbPath name) = return $ Just name -readUnitDatabase :: Logger -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId) +readUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId) readUnitDatabase logger cfg conf_file = do - isdir <- doesDirectoryExist conf_file + isdir <- OsPath.doesDirectoryExist conf_file proto_pkg_configs <- if isdir then readDirStyleUnitInfo conf_file else do - isfile <- doesFileExist conf_file + isfile <- OsPath.doesFileExist conf_file if isfile then do mpkgs <- tryReadOldFileStyleUnitInfo @@ -778,48 +780,49 @@ readUnitDatabase logger cfg conf_file = do Just pkgs -> return pkgs Nothing -> throwGhcExceptionIO $ InstallationError $ "ghc no longer supports single-file style package " ++ - "databases (" ++ conf_file ++ + "databases (" ++ show conf_file ++ ") use 'ghc-pkg init' to create the database with " ++ "the correct format." else throwGhcExceptionIO $ InstallationError $ - "can't find a package database at " ++ conf_file + "can't find a package database at " ++ show conf_file let -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot - conf_file' = dropTrailingPathSeparator conf_file - top_dir = unitConfigGHCDir cfg - pkgroot = takeDirectory conf_file' + conf_file' = OsPath.dropTrailingPathSeparator conf_file + top_dir = OsPath.unsafeEncodeUtf (unitConfigGHCDir cfg) + pkgroot = OsPath.takeDirectory conf_file' pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) proto_pkg_configs -- return $ UnitDatabase conf_file' pkg_configs1 where + readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo] readDirStyleUnitInfo conf_dir = do - let filename = conf_dir </> "package.cache" - cache_exists <- doesFileExist filename + let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache") + cache_exists <- OsPath.doesFileExist filename if cache_exists then do - debugTraceMsg logger 2 $ text "Using binary package database:" <+> text filename - readPackageDbForGhc filename + debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename + readPackageDbForGhc (OsPath.unsafeDecodeUtf filename) else do -- If there is no package.cache file, we check if the database is not -- empty by inspecting if the directory contains any .conf file. If it -- does, something is wrong and we fail. Otherwise we assume that the -- database is empty. debugTraceMsg logger 2 $ text "There is no package.cache in" - <+> text conf_dir + <+> ppr conf_dir <> text ", checking if the database is empty" - db_empty <- all (not . isSuffixOf ".conf") - <$> getDirectoryContents conf_dir + db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf")) + <$> OsPath.getDirectoryContents conf_dir if db_empty then do debugTraceMsg logger 3 $ text "There are no .conf files in" - <+> text conf_dir <> text ", treating" + <+> ppr conf_dir <> text ", treating" <+> text "package database as empty" return [] else throwGhcExceptionIO $ InstallationError $ - "there is no package.cache in " ++ conf_dir ++ + "there is no package.cache in " ++ show conf_dir ++ " even though package database is not empty" @@ -832,13 +835,13 @@ readUnitDatabase logger cfg conf_file = do -- assumes it's a file and tries to overwrite with 'writeFile'. -- ghc-pkg also cooperates with this workaround. tryReadOldFileStyleUnitInfo = do - content <- readFile conf_file `catchIO` \_ -> return "" + content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return "" if take 2 content == "[]" then do - let conf_dir = conf_file <.> "d" - direxists <- doesDirectoryExist conf_dir + let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d" + direxists <- OsPath.doesDirectoryExist conf_dir if direxists - then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir) + then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> ppr conf_dir) liftM Just (readDirStyleUnitInfo conf_dir) else return (Just []) -- ghc-pkg will create it when it's updated else return Nothing @@ -848,11 +851,11 @@ distrustAllUnits pkgs = map distrust pkgs where distrust pkg = pkg{ unitIsTrusted = False } -mungeUnitInfo :: FilePath -> FilePath +mungeUnitInfo :: OsPath -> OsPath -> UnitInfo -> UnitInfo mungeUnitInfo top_dir pkgroot = mungeDynLibFields - . mungeUnitInfoPaths (ST.pack top_dir) (ST.pack pkgroot) + . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot)) mungeDynLibFields :: UnitInfo -> UnitInfo mungeDynLibFields pkg = @@ -1373,7 +1376,7 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] where merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do debugTraceMsg logger 2 $ - text "loading package database" <+> text db_path + text "loading package database" <+> ppr db_path forM_ (Set.toList override_set) $ \pkg -> debugTraceMsg logger 2 $ text "package" <+> ppr pkg <+> ===================================== compiler/GHC/Utils/Misc.hs ===================================== @@ -137,6 +137,8 @@ import Control.Monad ( guard ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) +import qualified System.Directory.OsPath as OsPath +import System.OsPath (OsPath) import System.FilePath import Data.Bifunctor ( first, second ) @@ -1248,9 +1250,9 @@ getModificationUTCTime = getModificationTime -- -------------------------------------------------------------- -- check existence & modification time at the same time -modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime) +modificationTimeIfExists :: OsPath -> IO (Maybe UTCTime) modificationTimeIfExists f = - (do t <- getModificationUTCTime f; return (Just t)) + (do t <- OsPath.getModificationTime f; return (Just t)) `catchIO` \e -> if isDoesNotExistError e then return Nothing else ioError e ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -149,6 +149,7 @@ import Data.String import Data.Word import System.IO ( Handle ) import System.FilePath +import System.OsPath (OsPath, decodeUtf) import Text.Printf import Numeric (showFFloat) import Numeric.Natural (Natural) @@ -1101,6 +1102,8 @@ instance Outputable Extension where instance Outputable ModuleName where ppr = pprModuleName +instance Outputable OsPath where + ppr p = text $ either show id (decodeUtf p) pprModuleName :: IsLine doc => ModuleName -> doc pprModuleName (ModuleName nm) = ===================================== docs/users_guide/phases.rst ===================================== @@ -770,10 +770,9 @@ Options affecting code generation :type: dynamic :category: codegen - Generate position-independent code (code that can be put into shared - libraries). This currently works on Linux x86 and x86-64. On - Windows, position-independent code is never used so the flag is a - no-op on that platform. + Generate position-independent code (PIC). This code can be put into shared + libraries and is sometimes required by operating systems, e.g. systems using + Address Space Layout Randomization (ASLR). .. ghc-flag:: -fexternal-dynamic-refs :shortdesc: Generate code for linking against dynamic libraries @@ -790,9 +789,7 @@ Options affecting code generation :category: codegen Generate code in such a way to be linkable into a position-independent - executable This currently works on Linux x86 and x86-64. On Windows, - position-independent code is never used so the flag is a no-op on that - platform. To link the final executable use :ghc-flag:`-pie`. + executable. To link the final executable use :ghc-flag:`-pie`. .. ghc-flag:: -dynamic :shortdesc: Build dynamically-linked object files and executables ===================================== rts/linker/PEi386.c ===================================== @@ -552,7 +552,12 @@ static int compare_path(StgWord key1, StgWord key2) static void addLoadedDll(LoadedDllCache *cache, const pathchar *dll_name, HINSTANCE instance) { - insertHashTable_(cache->hash, (StgWord) dll_name, instance, hash_path); + // dll_name might be deallocated, we need to copy it to have a stable reference to the contents + // See #26613 + size_t size = wcslen(dll_name) + 1; + pathchar* dll_name_copy = stgMallocBytes(size * sizeof(pathchar), "addLoadedDll"); + wcsncpy(dll_name_copy, dll_name, size); + insertHashTable_(cache->hash, (StgWord) dll_name_copy, instance, hash_path); } static HINSTANCE isDllLoaded(const LoadedDllCache *cache, const pathchar *dll_name) ===================================== testsuite/tests/codeGen/should_run/T24016.hs ===================================== @@ -0,0 +1,24 @@ +module Main (main) where + +data Command + = Command1 + | Command2 + | Command3 + | Command4 + | Command5 + | Command6 -- Commenting this line works with -fPIC, uncommenting leads to a crash. + +main :: IO () +main = do + let x = case cmd of + Command1 -> 1 :: Int + Command2 -> 2 + Command3 -> 3 + Command4 -> 4 + Command5 -> 5 + Command6 -> 6 + putStrLn (show x) + +{-# NOINLINE cmd #-} +cmd :: Command +cmd = Command6 ===================================== testsuite/tests/codeGen/should_run/T24016.stdout ===================================== @@ -0,0 +1 @@ +6 ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -257,3 +257,4 @@ test('CCallConv', [req_c], compile_and_run, ['CCallConv_c.c']) test('T25364', normal, compile_and_run, ['']) test('T26061', normal, compile_and_run, ['']) test('T26537', normal, compile_and_run, ['-O2 -fregs-graph']) +test('T24016', normal, compile_and_run, ['-O1 -fPIC']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f3ccdc29eb988b3be39937051d12dce... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f3ccdc29eb988b3be39937051d12dce... You're receiving this email because of your account on gitlab.haskell.org.