Cheng Shao pushed to branch wip/T25821 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 - - - - - ed8a0669 by Ben Gamari at 2025-11-29T00:06:50+01:00 hadrian: Place user options after package arguments This makes it easier for the user to override the default package arguments with `UserSettings.hs`. Fixes #25821. ------------------------- Metric Decrease: T14697 ------------------------- - - - - - 9 changed files: - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToAsm/X86/Instr.hs - compiler/GHC/CmmToAsm/X86/Ppr.hs - docs/users_guide/phases.rst - hadrian/src/Settings.hs - 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: ===================================== 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) _ ===================================== 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 ===================================== hadrian/src/Settings.hs ===================================== @@ -35,7 +35,7 @@ getExtraArgs :: Args getExtraArgs = expr flavour >>= extraArgs getArgs :: Args -getArgs = mconcat [ defaultBuilderArgs, getExtraArgs, defaultPackageArgs ] +getArgs = mconcat [ defaultBuilderArgs, defaultPackageArgs, getExtraArgs ] getLibraryWays :: Ways getLibraryWays = expr flavour >>= libraryWays ===================================== 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/b650f96252e2fc18248def9b8490439... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b650f96252e2fc18248def9b8490439... You're receiving this email because of your account on gitlab.haskell.org.