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. 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 \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.
