Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

7 changed files:

Changes:

  • compiler/GHC/CmmToAsm/X86/CodeGen.hs
    ... ... @@ -376,7 +376,7 @@ stmtToInstrs bid stmt = do
    376 376 
           --We try to arrange blocks such that the likely branch is the fallthrough
    377 377 
           --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.
    378 378 
           CmmCondBranch arg true false _ -> genCondBranch bid true false arg
    379 
    -      CmmSwitch arg ids -> genSwitch arg ids
    379 
    +      CmmSwitch arg ids -> genSwitch arg ids bid
    380 380 
           CmmCall { cml_target = arg
    381 381 
                   , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)
    382 382 
           _ ->
    ... ... @@ -489,13 +489,6 @@ is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000
    489 489 
       where i64 = fromIntegral i :: Int64
    490 490
    491 491
    492 
    --- | Convert a BlockId to some CmmStatic data
    493 
    -jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic
    494 
    -jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config))
    495 
    -jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
    496 
    -    where blockLabel = blockLbl blockid
    497 
    -
    498 
    -
    499 492 
     -- -----------------------------------------------------------------------------
    500 493 
     -- General things for putting together code sequences
    501 494
    ... ... @@ -5375,11 +5368,52 @@ index (1),
    5375 5368 
         indexExpr    = UU_Conv(indexOffset); // == 1::I64
    5376 5369
    5377 5370 
     See #21186.
    5378 
    --}
    5379 5371
    5380 
    -genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock
    5372 
    +Note [Jump tables]
    5373 
    +~~~~~~~~~~~~~~~~~~
    5374 
    +The x86 backend has a virtual JMP_TBL instruction which payload can be used to
    5375 
    +generate both the jump instruction and the jump table contents. `genSwitch` is
    5376 
    +responsible for generating these JMP_TBL instructions.
    5377 
    +
    5378 
    +Depending on `-fPIC` flag and on the architecture, we generate the following
    5379 
    +jump table variants:
    5380 
    +
    5381 
    +  | Variant |  Arch  | Table's contents                       | Reference to the table |
    5382 
    +  |---------|--------|----------------------------------------|------------------------|
    5383 
    +  |     PIC |  Both  | Relative offset: target_lbl - base_lbl | PIC                    |
    5384 
    +  | Non-PIC | 64-bit | Absolute: target_lbl                   | Non-PIC (rip-relative) |
    5385 
    +  | Non-PIC | 32-bit | Absolute: target_lbl                   | Non-PIC (absolute)     |
    5386 
    +
    5387 
    +For the PIC variant, we store relative entries (`target_lbl - base_lbl`) in the
    5388 
    +jump table. Using absolute entries with PIC would require target_lbl symbols to
    5389 
    +be resolved at link time, hence to be global labels (currently they are local
    5390 
    +labels).
    5391 
    +
    5392 
    +We use the block_id of the code containing the jump as `base_lbl`. It ensures
    5393 
    +that target_lbl and base_lbl are close enough to each others, avoiding
    5394 
    +overflows.
    5395 
    +
    5396 
    +Historical note: in the past we used the table label `table_lbl` as base_lbl. It
    5397 
    +allowed the jumping code to only compute one global address (table_lbl) both to
    5398 
    +read the table and to compute the target address. However:
    5381 5399
    5382 
    -genSwitch expr targets = do
    5400 
    + * the table could be too far from the jump and on Windows which only
    5401 
    +   has 32-bit relative relocations (IMAGE_REL_AMD64_REL64 doesn't exist),
    5402 
    +   `dest_lbl - table_lbl` overflowed (see #24016)
    5403 
    +
    5404 
    + * Mac OS X/x86-64 linker was unable to handle `.quad L1 - L0`
    5405 
    +   relocations if L0 wasn't preceded by a non-anonymous label in its
    5406 
    +   section (which was the case with table_lbl). Hence we used to put the
    5407 
    +   jump table in the .text section in this case.
    5408 
    +
    5409 
    +
    5410 
    +-}
    5411 
    +
    5412 
    +-- | Generate a JMP_TBL instruction
    5413 
    +--
    5414 
    +-- See Note [Jump tables]
    5415 
    +genSwitch :: CmmExpr -> SwitchTargets -> BlockId -> NatM InstrBlock
    5416 
    +genSwitch expr targets bid = do
    5383 5417 
       config <- getConfig
    5384 5418 
       let platform = ncgPlatform config
    5385 5419 
           expr_w = cmmExprWidth platform expr
    ... ... @@ -5390,79 +5424,76 @@ genSwitch expr targets = do
    5390 5424 
           indexExpr = CmmMachOp
    5391 5425 
             (MO_UU_Conv expr_w (platformWordWidth platform))
    5392 5426 
             [indexExpr0]
    5393 
    -  if ncgPIC config
    5394 
    -  then do
    5395 
    -        (reg,e_code) <- getNonClobberedReg indexExpr
    5396 
    -           -- getNonClobberedReg because it needs to survive across t_code
    5397 
    -        lbl <- getNewLabelNat
    5398 
    -        let is32bit = target32Bit platform
    5399 
    -            os = platformOS platform
    5400 
    -            -- Might want to use .rodata.<function we're in> instead, but as
    5401 
    -            -- long as it's something unique it'll work out since the
    5402 
    -            -- references to the jump table are in the appropriate section.
    5403 
    -            rosection = case os of
    5404 
    -              -- on Mac OS X/x86_64, put the jump table in the text section to
    5405 
    -              -- work around a limitation of the linker.
    5406 
    -              -- ld64 is unable to handle the relocations for
    5407 
    -              --     .quad L1 - L0
    5408 
    -              -- if L0 is not preceded by a non-anonymous label in its section.
    5409 
    -              OSDarwin | not is32bit -> Section Text lbl
    5410 
    -              _ -> Section ReadOnlyData lbl
    5411 
    -        dynRef <- cmmMakeDynamicReference config DataReference lbl
    5412 
    -        (tableReg,t_code) <- getSomeReg $ dynRef
    5413 
    -        let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
    5414 
    -                                       (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))
    5415 
    -
    5416 
    -        return $ e_code `appOL` t_code `appOL` toOL [
    5417 
    -                                ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg),
    5418 
    -                                JMP_TBL (OpReg tableReg) ids rosection lbl
    5419 
    -                       ]
    5420 
    -  else do
    5421 
    -        (reg,e_code) <- getSomeReg indexExpr
    5422 
    -        lbl <- getNewLabelNat
    5423 
    -        let is32bit = target32Bit platform
    5424 
    -        if is32bit
    5425 
    -          then let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl))
    5426 
    -                   jmp_code = JMP_TBL op ids (Section ReadOnlyData lbl) lbl
    5427 
    -               in return $ e_code `appOL` unitOL jmp_code
    5428 
    -          else do
    5427 
    +
    5428 
    +      (offset, blockIds) = switchTargetsToTable targets
    5429 
    +      ids = map (fmap DestBlockId) blockIds
    5430 
    +
    5431 
    +      is32bit = target32Bit platform
    5432 
    +      fmt = archWordFormat is32bit
    5433 
    +
    5434 
    +  table_lbl <- getNewLabelNat
    5435 
    +  let bid_lbl = blockLbl bid
    5436 
    +  let table_section = Section ReadOnlyData table_lbl
    5437 
    +
    5438 
    +  -- see Note [Jump tables] for a description of the following 3 variants.
    5439 
    +  if
    5440 
    +    | ncgPIC config -> do
    5441 
    +      -- PIC support: store relative offsets in the jump table to allow the code
    5442 
    +      -- to be relocated without updating the table. The table itself and the
    5443 
    +      -- block label used to make the relative labels absolute are read in a PIC
    5444 
    +      -- way (via cmmMakeDynamicReference).
    5445 
    +      (reg,e_code) <- getNonClobberedReg indexExpr -- getNonClobberedReg because it needs to survive across t_code and j_code
    5446 
    +      (tableReg,t_code) <- getNonClobberedReg =<< cmmMakeDynamicReference config DataReference table_lbl
    5447 
    +      (targetReg,j_code) <- getSomeReg =<< cmmMakeDynamicReference config DataReference bid_lbl
    5448 
    +      pure $ e_code `appOL` t_code `appOL` j_code `appOL` toOL
    5449 
    +            [ ADD fmt (OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)))
    5450 
    +                      (OpReg targetReg)
    5451 
    +            , JMP_TBL (OpReg targetReg) ids table_section table_lbl (Just bid_lbl)
    5452 
    +            ]
    5453 
    +
    5454 
    +    | not is32bit -> do
    5455 
    +      -- 64-bit non-PIC code
    5456 
    +      (reg,e_code) <- getSomeReg indexExpr
    5457 
    +      tableReg <- getNewRegNat (intFormat (platformWordWidth platform))
    5458 
    +      targetReg <- getNewRegNat (intFormat (platformWordWidth platform))
    5459 
    +      pure $ e_code `appOL` toOL
    5429 5460 
                 -- See Note [%rip-relative addressing on x86-64].
    5430 
    -            tableReg <- getNewRegNat (intFormat (platformWordWidth platform))
    5431 
    -            targetReg <- getNewRegNat (intFormat (platformWordWidth platform))
    5432 
    -            let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))
    5433 
    -                fmt = archWordFormat is32bit
    5434 
    -                code = e_code `appOL` toOL
    5435 
    -                    [ LEA fmt (OpAddr (AddrBaseIndex EABaseRip EAIndexNone (ImmCLbl lbl))) (OpReg tableReg)
    5436 
    -                    , MOV fmt op (OpReg targetReg)
    5437 
    -                    , JMP_TBL (OpReg targetReg) ids (Section ReadOnlyData lbl) lbl
    5438 
    -                    ]
    5439 
    -            return code
    5440 
    -  where
    5441 
    -    (offset, blockIds) = switchTargetsToTable targets
    5442 
    -    ids = map (fmap DestBlockId) blockIds
    5461 
    +            [ LEA fmt (OpAddr (AddrBaseIndex EABaseRip EAIndexNone (ImmCLbl table_lbl))) (OpReg tableReg)
    5462 
    +            , MOV fmt (OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)))
    5463 
    +                      (OpReg targetReg)
    5464 
    +            , JMP_TBL (OpReg targetReg) ids table_section table_lbl Nothing
    5465 
    +            ]
    5466 
    +
    5467 
    +    | otherwise -> do
    5468 
    +      -- 32-bit non-PIC code is a straightforward jump to &table[entry].
    5469 
    +      (reg,e_code) <- getSomeReg indexExpr
    5470 
    +      pure $ e_code `appOL` unitOL
    5471 
    +            ( JMP_TBL (OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl table_lbl)))
    5472 
    +                      ids table_section table_lbl Nothing
    5473 
    +            )
    5443 5474
    5444 5475 
     generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr)
    5445 
    -generateJumpTableForInstr config (JMP_TBL _ ids section lbl)
    5446 
    -    = let getBlockId (DestBlockId id) = id
    5447 
    -          getBlockId _ = panic "Non-Label target in Jump Table"
    5448 
    -          blockIds = map (fmap getBlockId) ids
    5449 
    -      in Just (createJumpTable config blockIds section lbl)
    5450 
    -generateJumpTableForInstr _ _ = Nothing
    5451 
    -
    5452 
    -createJumpTable :: NCGConfig -> [Maybe BlockId] -> Section -> CLabel
    5453 
    -                -> GenCmmDecl (Alignment, RawCmmStatics) h g
    5454 
    -createJumpTable config ids section lbl
    5455 
    -    = let jumpTable
    5456 
    -            | ncgPIC config =
    5457 
    -                  let ww = ncgWordWidth config
    5458 
    -                      jumpTableEntryRel Nothing
    5459 
    -                          = CmmStaticLit (CmmInt 0 ww)
    5460 
    -                      jumpTableEntryRel (Just blockid)
    5461 
    -                          = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww)
    5462 
    -                          where blockLabel = blockLbl blockid
    5463 
    -                  in map jumpTableEntryRel ids
    5464 
    -            | otherwise = map (jumpTableEntry config) ids
    5465 
    -      in CmmData section (mkAlignment 1, CmmStaticsRaw lbl jumpTable)
    5476 
    +generateJumpTableForInstr config = \case
    5477 
    +  JMP_TBL _ ids section table_lbl mrel_lbl ->
    5478 
    +    let getBlockId (DestBlockId id) = id
    5479 
    +        getBlockId _ = panic "Non-Label target in Jump Table"
    5480 
    +        block_ids = map (fmap getBlockId) ids
    5481 
    +
    5482 
    +        jumpTable = case mrel_lbl of
    5483 
    +          Nothing      -> map mk_absolute block_ids           -- absolute entries
    5484 
    +          Just rel_lbl -> map (mk_relative rel_lbl) block_ids -- offsets relative to rel_lbl
    5485 
    +
    5486 
    +        mk_absolute = \case
    5487 
    +          Nothing      -> CmmStaticLit (CmmInt 0 (ncgWordWidth config))
    5488 
    +          Just blockid -> CmmStaticLit (CmmLabel (blockLbl blockid))
    5489 
    +
    5490 
    +        mk_relative rel_lbl = \case
    5491 
    +          Nothing      -> CmmStaticLit (CmmInt 0 (ncgWordWidth config))
    5492 
    +          Just blockid -> CmmStaticLit (CmmLabelDiffOff (blockLbl blockid) rel_lbl 0 (ncgWordWidth config))
    5493 
    +
    5494 
    +    in Just (CmmData section (mkAlignment 1, CmmStaticsRaw table_lbl jumpTable))
    5495 
    +
    5496 
    +  _ -> Nothing
    5466 5497
    5467 5498 
     extractUnwindPoints :: [Instr] -> [UnwindPoint]
    5468 5499 
     extractUnwindPoints instrs =

  • compiler/GHC/CmmToAsm/X86/Instr.hs
    ... ... @@ -252,6 +252,7 @@ data Instr
    252 252 
                           [Maybe JumpDest] -- Targets of the jump table
    253 253 
                           Section   -- Data section jump table should be put in
    254 254 
                           CLabel    -- Label of jump table
    255 
    +                      !(Maybe CLabel) -- Label used to compute relative offsets. Otherwise we store absolute addresses.
    255 256 
             -- | X86 call instruction
    256 257 
             | CALL        (Either Imm Reg) -- ^ Jump target
    257 258 
                           [RegWithFormat]  -- ^ Arguments (required for register allocation)
    ... ... @@ -486,7 +487,7 @@ regUsageOfInstr platform instr
    486 487 
         JXX    _ _          -> mkRU [] []
    487 488 
         JXX_GBL _ _         -> mkRU [] []
    488 489 
         JMP     op regs     -> mkRU (use_R addrFmt op regs) []
    489 
    -    JMP_TBL op _ _ _    -> mkRU (use_R addrFmt op []) []
    490 
    +    JMP_TBL op _ _ _ _  -> mkRU (use_R addrFmt op []) []
    490 491 
         CALL (Left _)  params   -> mkRU params (map mkFmt $ callClobberedRegs platform)
    491 492 
         CALL (Right reg) params -> mkRU (mk addrFmt reg:params) (map mkFmt $ callClobberedRegs platform)
    492 493 
         CLTD   fmt          -> mkRU [mk fmt eax] [mk fmt edx]
    ... ... @@ -812,7 +813,7 @@ patchRegsOfInstr platform instr env
    812 813 
         POP  fmt op          -> patch1 (POP  fmt) op
    813 814 
         SETCC cond op        -> patch1 (SETCC cond) op
    814 815 
         JMP op regs          -> JMP (patchOp op) regs
    815 
    -    JMP_TBL op ids s lbl -> JMP_TBL (patchOp op) ids s lbl
    816 
    +    JMP_TBL op ids s tl jl -> JMP_TBL (patchOp op) ids s tl jl
    816 817
    817 818 
         FMA3 fmt perm var x1 x2 x3 -> patch3 (FMA3 fmt perm var) x1 x2 x3
    818 819
    ... ... @@ -1016,9 +1017,9 @@ isJumpishInstr instr
    1016 1017 
     canFallthroughTo :: Instr -> BlockId -> Bool
    1017 1018 
     canFallthroughTo insn bid
    1018 1019 
       = case insn of
    1019 
    -    JXX _ target          -> bid == target
    1020 
    -    JMP_TBL _ targets _ _ -> all isTargetBid targets
    1021 
    -    _                     -> False
    1020 
    +    JXX _ target            -> bid == target
    1021 
    +    JMP_TBL _ targets _ _ _ -> all isTargetBid targets
    1022 
    +    _                       -> False
    1022 1023 
       where
    1023 1024 
         isTargetBid target = case target of
    1024 1025 
           Nothing                      -> True
    ... ... @@ -1031,9 +1032,9 @@ jumpDestsOfInstr
    1031 1032
    1032 1033 
     jumpDestsOfInstr insn
    1033 1034 
       = case insn of
    1034 
    -        JXX _ id        -> [id]
    1035 
    -        JMP_TBL _ ids _ _ -> [id | Just (DestBlockId id) <- ids]
    1036 
    -        _               -> []
    1035 
    +        JXX _ id            -> [id]
    1036 
    +        JMP_TBL _ ids _ _ _ -> [id | Just (DestBlockId id) <- ids]
    1037 
    +        _                   -> []
    1037 1038
    1038 1039
    1039 1040 
     patchJumpInstr
    ... ... @@ -1042,8 +1043,8 @@ patchJumpInstr
    1042 1043 
     patchJumpInstr insn patchF
    1043 1044 
       = case insn of
    1044 1045 
             JXX cc id       -> JXX cc (patchF id)
    1045 
    -        JMP_TBL op ids section lbl
    1046 
    -          -> JMP_TBL op (map (fmap (patchJumpDest patchF)) ids) section lbl
    1046 
    +        JMP_TBL op ids section table_lbl rel_lbl
    1047 
    +          -> JMP_TBL op (map (fmap (patchJumpDest patchF)) ids) section table_lbl rel_lbl
    1047 1048 
             _               -> insn
    1048 1049 
         where
    1049 1050 
             patchJumpDest f (DestBlockId id) = DestBlockId (f id)
    ... ... @@ -1504,14 +1505,14 @@ shortcutJump fn insn = shortcutJump' fn (setEmpty :: LabelSet) insn
    1504 1505 
                 Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id')
    1505 1506 
                 Just (DestImm imm)     -> shortcutJump' fn seen' (JXX_GBL cc imm)
    1506 1507 
             where seen' = setInsert id seen
    1507 
    -    shortcutJump' fn _ (JMP_TBL addr blocks section tblId) =
    1508 
    +    shortcutJump' fn _ (JMP_TBL addr blocks section table_lbl rel_lbl) =
    1508 1509 
             let updateBlock (Just (DestBlockId bid))  =
    1509 1510 
                     case fn bid of
    1510 1511 
                         Nothing   -> Just (DestBlockId bid )
    1511 1512 
                         Just dest -> Just dest
    1512 1513 
                 updateBlock dest = dest
    1513 1514 
                 blocks' = map updateBlock blocks
    1514 
    -        in  JMP_TBL addr blocks' section tblId
    1515 
    +        in  JMP_TBL addr blocks' section table_lbl rel_lbl
    1515 1516 
         shortcutJump' _ _ other = other
    1516 1517
    1517 1518 
     -- Here because it knows about JumpDest

  • compiler/GHC/CmmToAsm/X86/Ppr.hs
    ... ... @@ -895,7 +895,7 @@ pprInstr platform i = case i of
    895 895 
        JMP op _
    896 896 
           -> line $ text "\tjmp *" <> pprOperand platform (archWordFormat (target32Bit platform)) op
    897 897
    898 
    -   JMP_TBL op _ _ _
    898 
    +   JMP_TBL op _ _ _ _
    899 899 
           -> pprInstr platform (JMP op [])
    900 900
    901 901 
        CALL (Left imm) _

  • docs/users_guide/phases.rst
    ... ... @@ -770,10 +770,9 @@ Options affecting code generation
    770 770 
         :type: dynamic
    771 771 
         :category: codegen
    772 772
    773 
    -    Generate position-independent code (code that can be put into shared
    774 
    -    libraries). This currently works on Linux x86 and x86-64. On
    775 
    -    Windows, position-independent code is never used so the flag is a
    776 
    -    no-op on that platform.
    773 
    +    Generate position-independent code (PIC). This code can be put into shared
    774 
    +    libraries and is sometimes required by operating systems, e.g. systems using
    775 
    +    Address Space Layout Randomization (ASLR).
    777 776
    778 777 
     .. ghc-flag:: -fexternal-dynamic-refs
    779 778 
         :shortdesc: Generate code for linking against dynamic libraries
    ... ... @@ -790,9 +789,7 @@ Options affecting code generation
    790 789 
         :category: codegen
    791 790
    792 791 
         Generate code in such a way to be linkable into a position-independent
    793 
    -    executable This currently works on Linux x86 and x86-64. On Windows,
    794 
    -    position-independent code is never used so the flag is a no-op on that
    795 
    -    platform. To link the final executable use :ghc-flag:`-pie`.
    792 
    +    executable. To link the final executable use :ghc-flag:`-pie`.
    796 793
    797 794 
     .. ghc-flag:: -dynamic
    798 795 
         :shortdesc: Build dynamically-linked object files and executables

  • testsuite/tests/codeGen/should_run/T24016.hs
    1 
    +module Main (main) where
    2 
    +
    3 
    +data Command
    4 
    +  = Command1
    5 
    +  | Command2
    6 
    +  | Command3
    7 
    +  | Command4
    8 
    +  | Command5
    9 
    +  | Command6 -- Commenting this line works with -fPIC, uncommenting leads to a crash.
    10 
    +
    11 
    +main :: IO ()
    12 
    +main = do
    13 
    +  let x = case cmd of
    14 
    +           Command1 -> 1 :: Int
    15 
    +           Command2 -> 2
    16 
    +           Command3 -> 3
    17 
    +           Command4 -> 4
    18 
    +           Command5 -> 5
    19 
    +           Command6 -> 6
    20 
    +  putStrLn (show x)
    21 
    +
    22 
    +{-# NOINLINE cmd #-}
    23 
    +cmd :: Command
    24 
    +cmd = Command6

  • testsuite/tests/codeGen/should_run/T24016.stdout
    1 
    +6

  • testsuite/tests/codeGen/should_run/all.T
    ... ... @@ -257,3 +257,4 @@ test('CCallConv', [req_c], compile_and_run, ['CCallConv_c.c'])
    257 257 
     test('T25364', normal, compile_and_run, [''])
    258 258 
     test('T26061', normal, compile_and_run, [''])
    259 259 
     test('T26537', normal, compile_and_run, ['-O2 -fregs-graph'])
    260 
    +test('T24016', normal, compile_and_run, ['-O1 -fPIC'])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help