[Git][ghc/ghc][wip/supersven/ghc-9.10-riscv-ncg] 7 commits: Add comments to linker

Sven Tennie (@supersven) gitlab at gitlab.haskell.org
Sat Jun 29 17:53:43 UTC 2024



Sven Tennie pushed to branch wip/supersven/ghc-9.10-riscv-ncg at Glasgow Haskell Compiler / GHC


Commits:
7bef417a by Sven Tennie at 2024-06-29T09:30:25+02:00
Add comments to linker

- - - - -
bfb85d05 by Sven Tennie at 2024-06-29T11:25:39+02:00
Haddock / simple refactorings

- - - - -
e5d1829a by Sven Tennie at 2024-06-29T15:09:53+02:00
Reduce BL's power to its actual usage

- - - - -
541bd4c3 by Sven Tennie at 2024-06-29T15:11:47+02:00
Cleanup

- - - - -
65527494 by Sven Tennie at 2024-06-29T17:02:06+02:00
Cleanup J vs B/BL instruction duplication

- - - - -
3b66a6c2 by Sven Tennie at 2024-06-29T17:27:22+02:00
Simplify genCCall type

No need to carry Nothings around.

- - - - -
b52d9c5b by Sven Tennie at 2024-06-29T19:27:47+02:00
Cleanup

- - - - -


6 changed files:

- compiler/GHC/CmmToAsm/RV64/CodeGen.hs
- compiler/GHC/CmmToAsm/RV64/Instr.hs
- compiler/GHC/CmmToAsm/RV64/Ppr.hs
- rts/LinkerInternals.h
- rts/linker/elf_plt_riscv64.c
- rts/linker/elf_reloc_riscv64.c


Changes:

=====================================
compiler/GHC/CmmToAsm/RV64/CodeGen.hs
=====================================
@@ -190,7 +190,7 @@ genSwitch config expr targets = do
   tmp <- getNewRegNat fmt
   lbl <- getNewLabelNat
   dynRef <- cmmMakeDynamicReference config DataReference lbl
-  (tableReg, fmt2, t_code) <- getSomeReg $ dynRef
+  (tableReg, fmt2, t_code) <- getSomeReg dynRef
   let code =
         toOL [ COMMENT (text "indexExpr" <+> (text . show) indexExpr)
              , COMMENT (text "dynRef" <+> (text . show) dynRef)
@@ -274,7 +274,7 @@ stmtToInstrs bid stmt = do
   platform <- getPlatform
   case stmt of
     CmmUnsafeForeignCall target result_regs args
-       -> genCCall target result_regs args bid
+      -> (,Nothing) <$> genCCall target result_regs args bid
 
     _ -> (,Nothing) <$> case stmt of
       CmmComment s   -> return (unitOL (COMMENT (ftext s)))
@@ -330,26 +330,23 @@ swizzleRegisterRep :: Format -> Register -> Register
 swizzleRegisterRep format (Fixed _ reg code) = Fixed format reg code
 swizzleRegisterRep format (Any _ codefn)     = Any   format codefn
 
--- | Grab the Reg for a CmmReg
+-- | Grab a `Reg` for a `CmmReg`
+--
+-- `LocalReg`s are assigned virtual registers (`RegVirtual`), `GlobalReg`s are
+-- assigned real registers (`RegReal`). It is an error if a `GlobalReg` is not a
+-- STG register.
 getRegisterReg :: Platform -> CmmReg -> Reg
-
 getRegisterReg _ (CmmLocal (LocalReg u pk))
   = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)
-
 getRegisterReg platform (CmmGlobal mid)
   = case globalRegMaybe platform (globalRegUseGlobalReg mid) of
         Just reg -> RegReal reg
         Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
-        -- By this stage, the only MagicIds remaining should be the
-        -- ones which map to a real machine register on this
-        -- platform.  Hence if it's not mapped to a registers something
-        -- went wrong earlier in the pipeline.
 
 -- -----------------------------------------------------------------------------
 -- General things for putting together code sequences
 
--- | The dual to getAnyReg: compute an expression into a register, but
---      we don't mind which one it is.
+-- | Compute an expression into any register
 getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock)
 getSomeReg expr = do
   r <- getRegister expr
@@ -360,8 +357,10 @@ getSomeReg expr = do
     Fixed rep reg code ->
         return (reg, rep, code)
 
--- TODO OPT: we might be able give getRegister
---          a hint, what kind of register we want.
+-- | Compute an expression into any floating-point register
+--
+-- If the initial expression is not a floating-point expression, finally move
+-- the result into a floating-point register.
 getFloatReg :: HasCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock)
 getFloatReg expr = do
   r <- getRegister expr
@@ -382,9 +381,10 @@ getFloatReg expr = do
     Fixed rep reg code ->
       return (reg, rep, code)
 
--- TODO: TODO, bounds. We can't put any immediate
--- value in. They are constrained.
--- See Ticket 19911
+-- | Map `CmmLit` to `OpImm`
+--
+-- N.B. this is a partial function, because not all `CmmLit`s have an immediate
+-- representation.
 litToImm' :: CmmLit -> NatM (Operand, InstrBlock)
 litToImm' lit = return (OpImm (litToImm lit), nilOL)
 
@@ -943,7 +943,7 @@ getRegister' config plat expr =
           FNMSub -> float3Op w (\d n m a -> unitOL $ FMA FNMAdd d n m a)
 
         _ -> pprPanic "getRegister' (unhandled ternary CmmMachOp): " $
-                (pprMachOp op) <+> text "in" <+> (pdoc plat expr)
+                pprMachOp op <+> text "in" <+> pdoc plat expr
 
       where
           float3Op w op = do
@@ -1147,7 +1147,6 @@ addAlignmentCheck align wordWidth reg = do
     Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt jumpReg cmpReg okayLblId reg)
     Any fmt f -> Any fmt (\reg -> f reg `appOL` check fmt jumpReg cmpReg okayLblId reg)
   where
-    -- TODO: Reduce amount of parameters by making this a let binding
     check :: Format -> Reg -> Reg -> BlockId -> Reg -> InstrBlock
     check fmt jumpReg cmpReg okayLblId reg =
       let width = formatToWidth fmt
@@ -1159,7 +1158,7 @@ addAlignmentCheck align wordWidth reg = do
                   , BCOND EQ (OpReg width cmpReg) zero (TBlock okayLblId)
                   , COMMENT (text "Alignment check failed")
                   , LDR II64 (OpReg W64 jumpReg) (OpImm $ ImmCLbl mkBadAlignmentLabel)
-                  , J (TReg jumpReg)
+                  , B (TReg jumpReg)
                   , NEWBLOCK okayLblId
               ]
 
@@ -1455,7 +1454,7 @@ genCCall
     -> [CmmFormal]        -- where to put the result
     -> [CmmActual]        -- arguments (of mixed type)
     -> BlockId            -- The block we are in
-    -> NatM (InstrBlock, Maybe BlockId)
+    -> NatM InstrBlock
 -- TODO: Specialize where we can.
 -- Generic impl
 genCCall target dest_regs arg_regs bid = do
@@ -1469,23 +1468,20 @@ genCCall target dest_regs arg_regs bid = do
     -- be a foreign procedure with an address expr
     -- and a calling convention.
     ForeignTarget expr _cconv -> do
-      (call_target, call_target_code) <- case expr of
-        -- if this is a label, let's just directly to it.  This will produce the
-        -- correct CALL relocation for BL...
-        -- While this works on aarch64, for _most_ labels, it will fall short
-        -- where label branching only works for shoter distances (e.g. riscv)
-        -- (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL)
-        -- ... if it's not a label--well--let's compute the expression into a
-        -- register and jump to that. See Note [PLT vs GOT relocations]
-        _ -> do (reg, _format, reg_code) <- getSomeReg expr
-                pure (TReg reg, reg_code)
+      (call_target_reg, call_target_code) <-
+         -- Compute the address of the call target into a register. This
+         -- addressing enables us to jump through the whole address space
+         -- without further ado. PC-relative addressing would involve
+         -- instructions to do similar, though.
+         do (reg, _format, reg_code) <- getSomeReg expr
+            pure (reg, reg_code)
       -- compute the code and register logic for all arg_regs.
       -- this will give us the format information to match on.
       arg_regs' <- mapM getSomeReg arg_regs
 
       -- Now this is stupid.  Our Cmm expressions doesn't carry the proper sizes
       -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in
-      -- STG; this thenn breaks packing of stack arguments, if we need to pack
+      -- STG; this then breaks packing of stack arguments, if we need to pack
       -- for the pcs, e.g. darwinpcs.  Option one would be to fix the Int type
       -- in Cmm proper. Option two, which we choose here is to use extended Hint
       -- information to contain the size information and use that when packing
@@ -1519,10 +1515,10 @@ genCCall target dest_regs arg_regs bid = do
       let code = call_target_code          -- compute the label (possibly into a register)
             `appOL` moveStackDown (stackSpace `div` 8)
             `appOL` passArgumentsCode      -- put the arguments into x0, ...
-            `snocOL` BL call_target passRegs  -- branch and link.
+            `snocOL` BL call_target_reg passRegs  -- branch and link (C calls aren't tail calls, but return)
             `appOL` readResultsCode        -- parse the results into registers
             `appOL` moveStackUp (stackSpace `div` 8)
-      return (code, Nothing)
+      return code
 
     PrimTarget MO_F32_Fabs
       | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
@@ -1639,13 +1635,13 @@ genCCall target dest_regs arg_regs bid = do
         -- atomic_thread_fence(memory_order_release);
 --        MO_ReadBarrier      ->  return (unitOL (DMBSY DmbRead DmbRead), Nothing)
 --        MO_WriteBarrier     ->  return (unitOL (DMBSY DmbWrite DmbWrite), Nothing)
-        MO_AcquireFence -> return (unitOL (DMBSY DmbRead DmbReadWrite), Nothing)
-        MO_ReleaseFence -> return (unitOL (DMBSY DmbReadWrite DmbWrite), Nothing)
-        MO_SeqCstFence -> return (unitOL (DMBSY DmbReadWrite DmbReadWrite), Nothing)
+        MO_AcquireFence -> pure (unitOL (DMBSY DmbRead DmbReadWrite))
+        MO_ReleaseFence -> pure (unitOL (DMBSY DmbReadWrite DmbWrite))
+        MO_SeqCstFence -> pure (unitOL (DMBSY DmbReadWrite DmbReadWrite))
 
-        MO_Touch            ->  return (nilOL, Nothing) -- Keep variables live (when using interior pointers)
+        MO_Touch            -> pure nilOL -- Keep variables live (when using interior pointers)
         -- Prefetch
-        MO_Prefetch_Data _n -> return (nilOL, Nothing) -- Prefetch hint.
+        MO_Prefetch_Data _n -> pure nilOL -- Prefetch hint.
 
         -- Memory copy/set/move/cmp, with alignment for optimization
 
@@ -1692,10 +1688,8 @@ genCCall target dest_regs arg_regs bid = do
                       MemOrderRelease -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo
                   dst = getRegisterReg platform (CmmLocal dst_reg)
                   moDescr = (text . show) mo
-                  code =
-                    code_p `appOL`
-                    instrs
-              return (code, Nothing)
+                  code = code_p `appOL` instrs
+              return code
           | otherwise -> panic "mal-formed AtomicRead"
         mo@(MO_AtomicWrite w ord)
           | [p_reg, val_reg] <- arg_regs -> do
@@ -1718,7 +1712,7 @@ genCCall target dest_regs arg_regs bid = do
                     code_p `appOL`
                     code_val `appOL`
                     instrs
-              return (code, Nothing)
+              pure code
           | otherwise -> panic "mal-formed AtomicWrite"
         MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)
         MO_Cmpxchg w        -> mkCCall (cmpxchgLabel w)
@@ -1731,7 +1725,7 @@ genCCall target dest_regs arg_regs bid = do
     unsupported :: Show a => a -> b
     unsupported mop = panic ("outOfLineCmmOp: " ++ show mop
                           ++ " not supported here")
-    mkCCall :: FastString -> NatM (InstrBlock, Maybe BlockId)
+    mkCCall :: FastString -> NatM InstrBlock
     mkCCall name = do
       config <- getConfig
       target <- cmmMakeDynamicReference config CallReference $
@@ -1835,7 +1829,7 @@ genCCall target dest_regs arg_regs bid = do
       (reg_fx, _format_x, code_fx) <- getFloatReg arg_reg
       let dst = getRegisterReg platform (CmmLocal dest_reg)
       let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx)
-      return (code, Nothing)
+      pure code
 
 {- Note [RISCV64 far jumps]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1930,19 +1924,6 @@ genFarJump far_target =
         B (TReg ipReg)
       ]
 
--- | An unconditional jump to a far target
---
--- By loading the far target into a register for the jump, we can address the
--- whole memory range.
-genFarBranchAndLink :: (MonadUnique m) => BlockId -> [Reg] -> m InstrBlock
-genFarBranchAndLink far_target ps =
-  return
-    $ toOL
-      [ ann (text "Unconditional branch and link to: " <> ppr far_target)
-          $ LDR II64 (OpReg W64 ipReg) (OpImm (ImmCLbl (blockLbl far_target))),
-        BL (TReg ipReg) ps
-      ]
-
 -- See Note [RISCV64 far jumps]
 data BlockInRange = InRange | NotInRange BlockId
 
@@ -2004,18 +1985,6 @@ makeFarBranches {- only used when debugging -} _platform statics basic_blocks =
             NotInRange far_target -> do
               jmp_code <- genFarJump far_target
               pure (pos + instr_size instr, fromOL jmp_code)
-        J t ->
-          case target_in_range m t pos of
-            InRange -> pure (pos + instr_size instr, [instr])
-            NotInRange far_target -> do
-              jmp_code <- genFarJump far_target
-              pure (pos + instr_size instr, fromOL jmp_code)
-        BL t ps ->
-          case target_in_range m t pos of
-            InRange -> pure (pos + instr_size instr, [instr])
-            NotInRange far_target -> do
-              jmp_code <- genFarBranchAndLink far_target ps
-              pure (pos + instr_size instr, fromOL jmp_code)
         _ -> pure (pos + instr_size instr, [instr])
 
     target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange
@@ -2091,10 +2060,7 @@ makeFarBranches {- only used when debugging -} _platform statics basic_blocks =
       -- estimate the subsituted size for jumps to lables
       -- jumps to registers have size 1
       BCOND {} -> long_bc_jump_size
-      J (TBlock _) -> long_b_jump_size
-      J (TReg _) -> 1
       B (TBlock _) -> long_b_jump_size
       B (TReg _) -> 1
-      BL (TBlock _) _ -> long_b_jump_size
-      BL (TReg _) _ -> 1
+      BL _ _ -> 1
       J_TBL {} -> 1


=====================================
compiler/GHC/CmmToAsm/RV64/Instr.hs
=====================================
@@ -102,11 +102,10 @@ regUsageOfInstr platform instr = case instr of
   ORI dst src1 _           -> usage (regOp src1, regOp dst)
   XORI dst src1 _          -> usage (regOp src1, regOp dst)
   -- 4. Branch Instructions ----------------------------------------------------
-  J t                      -> usage (regTarget t, [])
   J_TBL _ _ t              -> usage ([t], [])
   B t                      -> usage (regTarget t, [])
   BCOND _ l r t            -> usage (regTarget t ++ regOp l ++ regOp r, [])
-  BL t ps                  -> usage (regTarget t ++ ps, callerSavedRegisters)
+  BL t ps                  -> usage (t : ps, callerSavedRegisters)
 
   -- 5. Atomic Instructions ----------------------------------------------------
   -- 6. Conditional Instructions -----------------------------------------------
@@ -200,10 +199,9 @@ patchRegsOfInstr instr env = case instr of
     XORI o1 o2 o3  -> XORI  (patchOp o1) (patchOp o2) (patchOp o3)
 
     -- 4. Branch Instructions --------------------------------------------------
-    J t            -> J (patchTarget t)
     J_TBL ids mbLbl t    -> J_TBL ids mbLbl (env t)
     B t            -> B (patchTarget t)
-    BL t ps          -> BL (patchTarget t) ps
+    BL t ps          -> BL (patchReg t) ps
     BCOND c o1 o2 t -> BCOND c (patchOp o1) (patchOp o2) (patchTarget t)
 
     -- 5. Atomic Instructions --------------------------------------------------
@@ -237,6 +235,9 @@ patchRegsOfInstr instr env = case instr of
         patchAddr :: AddrMode -> AddrMode
         patchAddr (AddrRegImm r1 i)  = AddrRegImm (env r1) i
         patchAddr (AddrReg r) = AddrReg (env r)
+        patchReg :: Reg -> Reg
+        patchReg = env
+
 --------------------------------------------------------------------------------
 
 -- | Checks whether this instruction is a jump/branch instruction.
@@ -246,7 +247,6 @@ patchRegsOfInstr instr env = case instr of
 isJumpishInstr :: Instr -> Bool
 isJumpishInstr instr = case instr of
   ANN _ i -> isJumpishInstr i
-  J {} -> True
   J_TBL {} -> True
   B {} -> True
   BL {} -> True
@@ -256,10 +256,8 @@ isJumpishInstr instr = case instr of
 -- | Get the `BlockId`s of the jump destinations (if any)
 jumpDestsOfInstr :: Instr -> [BlockId]
 jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i
-jumpDestsOfInstr (J t) = [id | TBlock id <- [t]]
 jumpDestsOfInstr (J_TBL ids _mbLbl _r) = catMaybes ids
 jumpDestsOfInstr (B t) = [id | TBlock id <- [t]]
-jumpDestsOfInstr (BL t _) = [id | TBlock id <- [t]]
 jumpDestsOfInstr (BCOND _ _ _ t) = [id | TBlock id <- [t]]
 jumpDestsOfInstr _ = []
 
@@ -271,10 +269,8 @@ patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr
 patchJumpInstr instr patchF =
   case instr of
     ANN d i -> ANN d (patchJumpInstr i patchF)
-    J (TBlock bid) -> J (TBlock (patchF bid))
     J_TBL ids mbLbl r -> J_TBL (map (fmap patchF) ids) mbLbl r
     B (TBlock bid) -> B (TBlock (patchF bid))
-    BL (TBlock bid) ps -> BL (TBlock (patchF bid)) ps
     BCOND c o1 o2 (TBlock bid) -> BCOND c o1 o2 (TBlock (patchF bid))
     _ -> panic $ "patchJumpInstr: " ++ instrCon instr
 
@@ -457,7 +453,6 @@ allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do
           block' = foldr insert_dealloc [] insns
 
       insert_dealloc insn r = case insn of
-        J _ -> dealloc ++ (insn : r)
         J_TBL {} -> dealloc ++ (insn : r)
         ANN _ e -> insert_dealloc e r
         _other | jumpDestsOfInstr insn /= []
@@ -577,12 +572,12 @@ data Instr
     | CSET Operand Operand Operand Cond   -- if(o2 cond o3) op <- 1 else op <- 0
 
     -- Branching.
-    -- TODO: Unused
-    | J Target            -- like B, but only generated from genJump. Used to distinguish genJumps from others.
-    -- | A `J` instruction with data for switch jump tables
+    -- | A jump instruction with data for switch/jump tables
     | J_TBL [Maybe BlockId] (Maybe CLabel) Reg
-    | B Target            -- unconditional branching b/br. (To a blockid, label or register)
-    | BL Target [Reg] -- branch and link (e.g. set x30 to next pc, and branch)
+    -- | Unconditional jump (no linking)
+    | B Target
+    -- | Unconditional jump, links return address (sets @ra@/@x1@)
+    | BL Reg [Reg]
     | BCOND Cond Operand Operand Target   -- branch with condition. b.<cond>
     -- | pseudo-op for far branch targets
 
@@ -641,7 +636,6 @@ instrCon i =
       LDR{} -> "LDR"
       LDRU{} -> "LDRU"
       CSET{} -> "CSET"
-      J{} -> "J"
       J_TBL{} -> "J_TBL"
       B{} -> "B"
       BL{} -> "BL"


=====================================
compiler/GHC/CmmToAsm/RV64/Ppr.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 module GHC.CmmToAsm.RV64.Ppr (pprNatCmmDecl, pprInstr) where
 
 import GHC.Prelude hiding (EQ)
@@ -25,19 +26,18 @@ import GHC.Utils.Outputable
 
 import GHC.Utils.Panic
 
--- TODO: Move function down to where it is used.
-pprProcAlignment :: IsDoc doc => NCGConfig -> doc
-pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config)
-   where
-      platform = ncgPlatform config
-
-pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc
+pprNatCmmDecl :: forall doc. IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc
 pprNatCmmDecl config (CmmData section dats) =
   pprSectionAlign config section $$ pprDatas config dats
 
 pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
-  let platform = ncgPlatform config in
-  pprProcAlignment config $$
+  let
+    platform = ncgPlatform config
+
+    pprProcAlignment :: doc
+    pprProcAlignment = maybe empty (pprAlign . mkAlignment) (ncgProcAlignment config)
+  in
+  pprProcAlignment $$
   case topInfoTable proc of
     Nothing ->
         -- special case for code without info table:
@@ -78,21 +78,26 @@ pprLabel platform lbl =
    $$ pprTypeDecl platform lbl
    $$ line (pprAsmLabel platform lbl <> char ':')
 
--- TODO: Delete unused parameter.
-pprAlign :: IsDoc doc => Platform -> Alignment -> doc
-pprAlign _platform alignment
+pprAlign :: IsDoc doc => Alignment -> doc
+pprAlign alignment
+-- "The .align directive for RISC-V is an alias to .p2align, which aligns to a
+-- power of two, so .align 2 means align to 4 bytes. Because the definition of
+-- the .align directive varies by architecture, it is recommended to use the
+-- unambiguous .p2align or .balign directives instead."
+-- (https://github.com/riscv-non-isa/riscv-asm-manual/blob/main/riscv-asm.md#-align)
         = line $ text "\t.balign " <> int (alignmentBytes alignment)
 
--- TODO: Delete unused parameters.
 -- | Print appropriate alignment for the given section type.
-pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc
-pprAlignForSection _platform _seg
-    -- .balign is stable, whereas .align is platform dependent.
-    = line (text "\t.balign 8") --  always 8
+--
+-- Currently, this always aligns to a full machine word (8 byte.) A future
+-- improvement could be to really do this per section type (though, it's
+-- probably not a big gain.)
+pprAlignForSection :: IsDoc doc => SectionType -> doc
+pprAlignForSection _seg = pprAlign . mkAlignment $ 8
 
 -- | Print section header and appropriate alignment for that section.
 --
--- This one will emit the header:
+-- This will e.g. emit a header like:
 --
 --     .section .text
 --     .balign 8
@@ -102,7 +107,7 @@ pprSectionAlign _config (Section (OtherSection _) _) =
   panic "RV64.Ppr.pprSectionAlign: unknown section"
 pprSectionAlign config sec@(Section seg _) =
     line (pprSectionHeader config sec)
-    $$ pprAlignForSection (ncgPlatform config) seg
+    $$ pprAlignForSection seg
 
 pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure name
                 -> doc
@@ -114,14 +119,16 @@ pprBlockEndLabel :: IsLine doc => Platform -> CLabel -- ^ Block name
 pprBlockEndLabel platform lbl =
     pprAsmLabel platform (mkAsmTempEndLabel lbl) <> colon
 
--- | Output the ELF .size directive.
-pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc
+-- | Output the ELF .size directive (if needed.)
+pprSizeDecl :: (IsDoc doc) => Platform -> CLabel -> doc
 pprSizeDecl platform lbl
- = if osElfTarget (platformOS platform)
-   then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl)
-   else empty
+  | osElfTarget (platformOS platform) =
+      line $ text "\t.size" <+> asmLbl <> text ", .-" <> asmLbl
+  where
+    asmLbl = pprAsmLabel platform lbl
+pprSizeDecl _ _ = empty
 
-pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr
+pprBasicBlock :: (IsDoc doc) => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr
               -> doc
 pprBasicBlock config info_env (BasicBlock blockid instrs)
   = maybe_infotable $
@@ -176,7 +183,6 @@ pprDatas config (CmmStaticsRaw lbl dats)
    where
       platform = ncgPlatform config
 
--- TODO: Unused parameter.
 pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc
 pprData _config (CmmString str) = line (pprString str)
 pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path)
@@ -381,35 +387,40 @@ pprReg w r = case r of
          -- no support for widths > W64.
          | otherwise = pprPanic "Unsupported width in register (max is 64)" (ppr w <+> int i)
 
+-- | Single precission `Operand` (floating-point)
 isSingleOp :: Operand -> Bool
 isSingleOp (OpReg W32 _) = True
 isSingleOp _ = False
 
+-- | Double precission `Operand` (floating-point)
 isDoubleOp :: Operand -> Bool
 isDoubleOp (OpReg W64 _) = True
 isDoubleOp _ = False
 
+-- | `Operand` is an immediate value
 isImmOp :: Operand -> Bool
 isImmOp (OpImm _) = True
 isImmOp _ = False
 
+-- | `Operand` is an immediate @0@ value
 isImmZero :: Operand -> Bool
 isImmZero (OpImm (ImmFloat 0)) = True
 isImmZero (OpImm (ImmDouble 0)) = True
 isImmZero (OpImm (ImmInt 0)) = True
 isImmZero _ = False
 
+-- | `Target` represents a label
 isLabel :: Target -> Bool
 isLabel (TBlock _) = True
 isLabel _ = False
 
-getLabel :: IsLine doc => Platform -> Target -> doc
+getLabel :: (IsLine doc) => Platform -> Target -> doc
 getLabel platform (TBlock bid) = pprBlockId platform bid
+  where
+    pprBlockId :: (IsLine doc) => Platform -> BlockId -> doc
+    pprBlockId platform bid = pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
 getLabel _platform _other = panic "Cannot turn this into a label"
 
-pprBlockId :: IsLine doc => Platform -> BlockId -> doc
-pprBlockId platform bid = pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
-
 pprInstr :: IsDoc doc => Platform -> Instr -> doc
 pprInstr platform instr = case instr of
   -- Meta Instructions ---------------------------------------------------------
@@ -506,14 +517,11 @@ pprInstr platform instr = case instr of
   XORI o1 o2 o3 -> op3 (text "\txori") o1 o2 o3
 
   -- 4. Branch Instructions ----------------------------------------------------
-  J t             -> pprInstr platform (B t)
-  J_TBL _ _ r     -> pprInstr platform (J (TReg r))
-  -- TODO: This is odd: (B)ranch and branch and link (BL) do the same: branch and link
+  J_TBL _ _ r     -> pprInstr platform (B (TReg r))
   B l | isLabel l -> line $ text "\tjal" <+> pprOp platform x0 <> comma <+> getLabel platform l
-  B (TReg r)      -> line $ text "\tjalr" <+> text "x0" <> comma <+> pprReg W64 r <> comma <+> text "0"
+  B (TReg r)      -> line $ text "\tjalr" <+> pprOp platform x0 <> comma <+> pprReg W64 r <> comma <+> text "0"
 
-  BL l _ | isLabel l-> line $ text "\tcall" <+> getLabel platform l
-  BL (TReg r) _ -> line $ text "\tjalr" <+> text "x1" <> comma <+> pprReg W64 r <> comma <+> text "0"
+  BL r _ -> line $ text "\tjalr" <+> text "x1" <> comma <+> pprReg W64 r <> comma <+> text "0"
 
   BCOND c l r t | isLabel t ->
     line $ text "\t" <> pprBcond c <+> pprOp platform l <> comma <+> pprOp platform r <> comma <+> getLabel platform t


=====================================
rts/LinkerInternals.h
=====================================
@@ -220,8 +220,9 @@ typedef struct _Segment {
 #define NEED_M32 1
 #endif
 
-/* Jump Islands are sniplets of machine code required for relative
- * address relocations on the PowerPC, x86_64 and ARM.
+/* Jump Islands are sniplets of machine code required for relative address
+ * relocations on the PowerPC, x86_64 and ARM. On RISCV64 we use symbolextras
+ * like a GOT for locals where SymbolExtra represents one entry.
  */
 typedef struct {
 #if defined(powerpc_HOST_ARCH)


=====================================
rts/linker/elf_plt_riscv64.c
=====================================
@@ -2,6 +2,7 @@
 #include "elf_compat.h"
 #include "elf_plt_riscv64.h"
 #include "rts/Messages.h"
+#include "linker/ElfTypes.h"
 
 #include <stdint.h>
 #include <stdlib.h>
@@ -35,6 +36,7 @@ bool needStubForRelaRISCV64(Elf_Rela *rela) {
 
 // After the global offset table (GOT) has been set up, we can use these three
 // instructions to jump to the target address / function:
+//
 //  1. AUIPC ip, %pcrel_hi(addr)
 //  2. LD ip, %pcrel_lo(addr)(ip)
 //  3. JARL x0, ip, 0
@@ -43,6 +45,10 @@ bool needStubForRelaRISCV64(Elf_Rela *rela) {
 // that would require loading a 64-bit constant which is a nightmare to do in
 // riscv64 assembly. (See
 // https://github.com/riscv-non-isa/riscv-elf-psabi-doc/blob/5ffe5b5aeedb37b1c1c0c3d94641267d9ad4795a/riscv-elf.adoc#procedure-linkage-table)
+//
+// So far, PC-relative addressing seems to be good enough. If it ever turns out
+// to be not, one could (additionally for out-of-range cases?) encode absolute
+// addressing here.
 bool makeStubRISCV64(Stub *s) {
   uint32_t *P = (uint32_t *)s->addr;
   int32_t addr = (uint64_t)s->got_addr - (uint64_t)P;


=====================================
rts/linker/elf_reloc_riscv64.c
=====================================
@@ -109,8 +109,6 @@ char *relocationTypeToString(Elf64_Xword type) {
   }
 }
 
-#define Page(x) ((x) & ~0xFFF)
-
 STG_NORETURN
 int32_t decodeAddendRISCV64(Section *section STG_UNUSED,
                             Elf_Rel *rel STG_UNUSED) {
@@ -121,7 +119,7 @@ int32_t decodeAddendRISCV64(Section *section STG_UNUSED,
 // Make sure that V can be represented as an N bit signed integer.
 void checkInt(inst_t *loc, int32_t v, int n) {
   if (v != signExtend32(v, n)) {
-    debugBelch("Relocation at 0x%x is out of range. value: 0x%x (%d), "
+    barf("Relocation at 0x%x is out of range. value: 0x%x (%d), "
                "sign-extended value: 0x%x (%d), max bits 0x%x (%d)\n",
                *loc, v, v, signExtend32(v, n), signExtend32(v, n), n, n);
   }
@@ -569,7 +567,6 @@ int32_t computeAddend(ElfRelocationATable * relaTab, unsigned relNo, Elf_Rel *re
   case R_RISCV_SUB32:
     FALLTHROUGH;
   case R_RISCV_SUB64:
-    // TODO: Is this '+' correct? Not '-'?
     return S + A; // Subtract from V when value is set
   case R_RISCV_SET6:
     FALLTHROUGH;



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f09c64f57add406953f0c27bd77f55941e379c1b...b52d9c5bcd03a155f2358d704ed8c2cc07f74fc3

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f09c64f57add406953f0c27bd77f55941e379c1b...b52d9c5bcd03a155f2358d704ed8c2cc07f74fc3
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240629/574c4eed/attachment-0001.html>


More information about the ghc-commits mailing list