[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