[Git][ghc/ghc][wip/supersven/ghc-9.10-riscv-ncg] 5 commits: Overhaul comments
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sun Jun 30 17:32:07 UTC 2024
Sven Tennie pushed to branch wip/supersven/ghc-9.10-riscv-ncg at Glasgow Haskell Compiler / GHC
Commits:
3096a840 by Sven Tennie at 2024-06-30T18:23:14+02:00
Overhaul comments
- - - - -
e5632cba by Sven Tennie at 2024-06-30T18:23:49+02:00
Remove superfluous "do"
- - - - -
e64f0de3 by Sven Tennie at 2024-06-30T18:26:34+02:00
Cleanup genCondBranch
NatM is also an Applicative
- - - - -
7b46b33f by Sven Tennie at 2024-06-30T18:38:37+02:00
C-CallingConv: Stack entries are always word-sized
- - - - -
3b7865a7 by Sven Tennie at 2024-06-30T19:30:59+02:00
Split genCCall for readability
- - - - -
3 changed files:
- compiler/GHC/CmmToAsm/RV64/CodeGen.hs
- compiler/GHC/CmmToAsm/RV64/Instr.hs
- compiler/GHC/CmmToAsm/RV64/Ppr.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/RV64/CodeGen.hs
=====================================
@@ -836,7 +836,7 @@ getRegister' config plat expr =
MO_U_Quot w -> intOp False w (\d x y -> unitOL $ annExpr expr (DIVU d x y))
MO_U_Rem w -> intOp False w (\d x y -> unitOL $ annExpr expr (REMU d x y))
- -- Signed comparisons -- see Note [CSET)
+ -- Signed comparisons
MO_S_Ge w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SGE))
MO_S_Le w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SLE))
MO_S_Gt w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SGT))
@@ -1308,15 +1308,22 @@ genCondJump bid expr = do
_ -> pprPanic "RV64.genCondJump: " (text $ show expr)
-genCondBranch :: BlockId -- the true branch target
- -> BlockId -- the false branch target
- -> CmmExpr -- the condition on which to branch
- -> NatM InstrBlock -- Instructions
-
-genCondBranch true false expr = do
- b1 <- genCondJump true expr
- b2 <- genBranch false
- return (b1 `appOL` b2)
+-- | Generate conditional branching instructions
+--
+-- This is basically an "if with else" statement.
+genCondBranch ::
+ -- | the true branch target
+ BlockId ->
+ -- | the false branch target
+ BlockId ->
+ -- | the condition on which to branch
+ CmmExpr ->
+ -- | Instructions
+ NatM InstrBlock
+genCondBranch true false expr =
+ appOL
+ <$> genCondJump true expr
+ <*> genBranch false
-- -----------------------------------------------------------------------------
-- Generating C calls
@@ -1403,17 +1410,11 @@ genCCall
-> NatM InstrBlock
-- TODO: Specialize where we can.
-- Generic impl
-genCCall target dest_regs arg_regs = do
- -- we want to pass arg_regs into allArgRegs
- -- pprTraceM "genCCall target" (ppr target)
- -- pprTraceM "genCCall formal" (ppr dest_regs)
- -- pprTraceM "genCCall actual" (ppr arg_regs)
-
- case target of
+genCCall target@(ForeignTarget expr _cconv) dest_regs arg_regs = do
+ -- we want to pass arg_regs into allArgRegs
-- The target :: ForeignTarget call can either
-- be a foreign procedure with an address expr
-- and a calling convention.
- ForeignTarget expr _cconv -> do
(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
@@ -1435,13 +1436,7 @@ genCCall target dest_regs arg_regs = do
let (_res_hints, arg_hints) = foreignTargetHints target
arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints
- (stackSpace', passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL
-
- -- if we pack the stack, we may need to adjust to multiple of 8byte.
- -- if we don't pack the stack, it will always be multiple of 8.
- let stackSpace = if stackSpace' `mod` 8 /= 0
- then 8 * (stackSpace' `div` 8 + 1)
- else stackSpace'
+ (stackSpaceWords, passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL
readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL
@@ -1459,25 +1454,111 @@ genCCall target dest_regs arg_regs = do
, DELTA 0 ]
let code = call_target_code -- compute the label (possibly into a register)
- `appOL` moveStackDown (stackSpace `div` 8)
+ `appOL` moveStackDown stackSpaceWords
`appOL` passArgumentsCode -- put the arguments into x0, ...
`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)
+ `appOL` moveStackUp stackSpaceWords
return code
+ where
+ -- Implementiation of the RISCV ABI calling convention.
+ -- https://github.com/riscv-non-isa/riscv-elf-psabi-doc/blob/948463cd5dbebea7c1869e20146b17a2cc8fda2f/riscv-cc.adoc#integer-calling-convention
+ passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)
+ -- Base case: no more arguments to pass (left)
+ passArguments _ _ [] stackSpaceWords accumRegs accumCode = return (stackSpaceWords, accumRegs, accumCode)
+
+ -- Still have GP regs, and we want to pass an GP argument.
+ passArguments (gpReg:gpRegs) fpRegs ((r, format, hint, code_r):args) stackSpaceWords accumRegs accumCode | isIntFormat format = do
+ -- RISCV64 Integer Calling Convention: "When passed in registers or on the
+ -- stack, integer scalars narrower than XLEN bits are widened according to
+ -- the sign of their type up to 32 bits, then sign-extended to XLEN bits."
+ let w = formatToWidth format
+ assignArg = if hint == SignedHint then
+ COMMENT (text "Pass gp argument sign-extended (SignedHint): " <> ppr r) `consOL`
+ signExtend w W64 r gpReg
+
+ else toOL [COMMENT (text "Pass gp argument sign-extended (SignedHint): " <> ppr r)
+ , MOV (OpReg w gpReg) (OpReg w r)]
+ accumCode' = accumCode `appOL`
+ code_r `appOL`
+ assignArg
+ passArguments gpRegs fpRegs args stackSpaceWords (gpReg:accumRegs) accumCode'
+
+ -- Still have FP regs, and we want to pass an FP argument.
+ passArguments gpRegs (fpReg:fpRegs) ((r, format, _hint, code_r):args) stackSpaceWords accumRegs accumCode | isFloatFormat format = do
+ let w = formatToWidth format
+ mov = MOV (OpReg w fpReg) (OpReg w r)
+ accumCode' = accumCode `appOL`
+ code_r `snocOL`
+ ann (text "Pass fp argument: " <> ppr r) mov
+ passArguments gpRegs fpRegs args stackSpaceWords (fpReg:accumRegs) accumCode'
+
+ -- No mor regs left to pass. Must pass on stack.
+ passArguments [] [] ((r, format, hint, code_r) : args) stackSpaceWords accumRegs accumCode = do
+ let w = formatToWidth format
+ str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 2) (ImmInt stackSpaceWords)))
+ stackCode =
+ if hint == SignedHint
+ then
+ code_r
+ `appOL` signExtend w W64 r ipReg
+ `snocOL` ann (text "Pass signed argument (size " <> ppr w <> text ") on the stack: " <> ppr ipReg) str
+ else
+ code_r
+ `snocOL` ann (text "Pass unsigned argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str
+ passArguments [] [] args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode)
+
+ -- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then.
+ passArguments [] fpRegs ((r, format, _hint, code_r):args) stackSpaceWords accumRegs accumCode | isIntFormat format = do
+ let w = formatToWidth format
+ str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 2) (ImmInt stackSpaceWords)))
+ stackCode = code_r `snocOL`
+ ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str
+ passArguments [] fpRegs args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode)
+
+ -- Still have gpRegs left, but want to pass a FP argument. Must be passed in gpReg then.
+ passArguments (gpReg:gpRegs) [] ((r, format, _hint, code_r):args) stackSpaceWords accumRegs accumCode | isFloatFormat format = do
+ let w = formatToWidth format
+ mov = MOV (OpReg w gpReg) (OpReg w r)
+ accumCode' = accumCode `appOL`
+ code_r `snocOL`
+ ann (text "Pass fp argument in gpReg: " <> ppr r) mov
+ passArguments gpRegs [] args stackSpaceWords (gpReg:accumRegs) accumCode'
+
+ passArguments _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state")
+
+ readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM InstrBlock
+ readResults _ _ [] _ accumCode = return accumCode
+ readResults [] _ _ _ _ = do
+ platform <- getPlatform
+ pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target)
+ readResults _ [] _ _ _ = do
+ platform <- getPlatform
+ pprPanic "genCCall, out of fp registers when reading results" (pdoc platform target)
+ readResults (gpReg:gpRegs) (fpReg:fpRegs) (dst:dsts) accumRegs accumCode = do
+ -- gp/fp reg -> dst
+ platform <- getPlatform
+ let rep = cmmRegType (CmmLocal dst)
+ format = cmmTypeFormat rep
+ w = cmmRegWidth (CmmLocal dst)
+ r_dst = getRegisterReg platform (CmmLocal dst)
+ if isFloatFormat format
+ then readResults (gpReg:gpRegs) fpRegs dsts (fpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg))
+ else readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) $
+ accumCode `snocOL`
+ MOV (OpReg w r_dst) (OpReg w gpReg) `appOL`
+ -- truncate, otherwise an unexpectedly big value might be used in upfollowing calculations
+ truncateReg W64 w r_dst
+
+genCCall (PrimTarget mop) dest_regs arg_regs = do
+ case mop of
+ MO_F32_Fabs
+ | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
+ unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg
+ MO_F64_Fabs
+ | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
+ unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg
- PrimTarget MO_F32_Fabs
- | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
- unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg
- PrimTarget MO_F64_Fabs
- | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
- unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg
-
- -- or a possibly side-effecting machine operation
- -- mop :: CallishMachOp (see GHC.Cmm.MachOp)
- PrimTarget mop -> do
- -- We'll need config to construct forien targets
- case mop of
-- 64 bit float ops
MO_F64_Pwr -> mkCCall "pow"
@@ -1679,97 +1760,6 @@ genCCall target dest_regs arg_regs = do
let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn
genCCall (ForeignTarget target cconv) dest_regs arg_regs
- -- Implementiation of the RISCV ABI calling convention.
- -- https://github.com/riscv-non-isa/riscv-elf-psabi-doc/blob/948463cd5dbebea7c1869e20146b17a2cc8fda2f/riscv-cc.adoc#integer-calling-convention
- passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)
- -- Base case: no more arguments to pass (left)
- passArguments _ _ [] stackSpace accumRegs accumCode = return (stackSpace, accumRegs, accumCode)
-
- -- Still have GP regs, and we want to pass an GP argument.
- passArguments (gpReg:gpRegs) fpRegs ((r, format, hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do
- -- RISCV64 Integer Calling Convention: "When passed in registers or on the
- -- stack, integer scalars narrower than XLEN bits are widened according to
- -- the sign of their type up to 32 bits, then sign-extended to XLEN bits."
- let w = formatToWidth format
- assignArg = if hint == SignedHint then
- COMMENT (text "Pass gp argument sign-extended (SignedHint): " <> ppr r) `consOL`
- signExtend w W64 r gpReg
-
- else toOL [COMMENT (text "Pass gp argument sign-extended (SignedHint): " <> ppr r)
- , MOV (OpReg w gpReg) (OpReg w r)]
- accumCode' = accumCode `appOL`
- code_r `appOL`
- assignArg
- passArguments gpRegs fpRegs args stackSpace (gpReg:accumRegs) accumCode'
-
- -- Still have FP regs, and we want to pass an FP argument.
- passArguments gpRegs (fpReg:fpRegs) ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do
- let w = formatToWidth format
- mov = MOV (OpReg w fpReg) (OpReg w r)
- accumCode' = accumCode `appOL`
- code_r `snocOL`
- ann (text "Pass fp argument: " <> ppr r) mov
- passArguments gpRegs fpRegs args stackSpace (fpReg:accumRegs) accumCode'
-
- -- No mor regs left to pass. Must pass on stack.
- passArguments [] [] ((r, format, hint, code_r) : args) stackSpace accumRegs accumCode = do
- let w = formatToWidth format
- space = 8
- str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 2) (ImmInt stackSpace)))
- stackCode =
- if hint == SignedHint
- then
- code_r
- `appOL` signExtend w W64 r ipReg
- `snocOL` ann (text "Pass signed argument (size " <> ppr w <> text ") on the stack: " <> ppr ipReg) str
- else
- code_r
- `snocOL` ann (text "Pass unsigned argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str
- passArguments [] [] args (stackSpace + space) accumRegs (stackCode `appOL` accumCode)
-
- -- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then.
- passArguments [] fpRegs ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do
- let w = formatToWidth format
- space = 8
- str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 2) (ImmInt stackSpace)))
- stackCode = code_r `snocOL`
- ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str
- passArguments [] fpRegs args (stackSpace+space) accumRegs (stackCode `appOL` accumCode)
-
- -- Still have gpRegs left, but want to pass a FP argument. Must be passed in gpReg then.
- passArguments (gpReg:gpRegs) [] ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do
- let w = formatToWidth format
- mov = MOV (OpReg w gpReg) (OpReg w r)
- accumCode' = accumCode `appOL`
- code_r `snocOL`
- ann (text "Pass fp argument in gpReg: " <> ppr r) mov
- passArguments gpRegs [] args stackSpace (gpReg:accumRegs) accumCode'
-
- passArguments _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state")
-
- readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM InstrBlock
- readResults _ _ [] _ accumCode = return accumCode
- readResults [] _ _ _ _ = do
- platform <- getPlatform
- pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target)
- readResults _ [] _ _ _ = do
- platform <- getPlatform
- pprPanic "genCCall, out of fp registers when reading results" (pdoc platform target)
- readResults (gpReg:gpRegs) (fpReg:fpRegs) (dst:dsts) accumRegs accumCode = do
- -- gp/fp reg -> dst
- platform <- getPlatform
- let rep = cmmRegType (CmmLocal dst)
- format = cmmTypeFormat rep
- w = cmmRegWidth (CmmLocal dst)
- r_dst = getRegisterReg platform (CmmLocal dst)
- if isFloatFormat format
- then readResults (gpReg:gpRegs) fpRegs dsts (fpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg))
- else readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) $
- accumCode `snocOL`
- MOV (OpReg w r_dst) (OpReg w gpReg) `appOL`
- -- truncate, otherwise an unexpectedly big value might be used in upfollowing calculations
- truncateReg W64 w r_dst
-
unaryFloatOp w op arg_reg dest_reg = do
platform <- getPlatform
(reg_fx, _format_x, code_fx) <- getFloatReg arg_reg
=====================================
compiler/GHC/CmmToAsm/RV64/Instr.hs
=====================================
@@ -568,8 +568,11 @@ data Instr
-- Load and stores.
-- Conditional instructions
- -- This is a synthetic operation.
- | CSET Operand Operand Operand Cond -- if(o2 cond o3) op <- 1 else op <- 0
+
+ -- | Pseudo-op for conditional setting of a register.
+ --
+ -- @if(o2 cond o3) op <- 1 else op <- 0@
+ | CSET Operand Operand Operand Cond
-- Branching.
-- | A jump instruction with data for switch/jump tables
@@ -584,13 +587,13 @@ data Instr
-- 8. Synchronization Instructions -----------------------------------------
| DMBSY DmbType DmbType
-- 9. Floating Point Instructions
- -- Float ConVerT
+ -- | Float ConVerT
| FCVT Operand Operand
- -- Signed ConVerT Float
+ -- | Signed ConVerT Float
| SCVTF Operand Operand
- -- Float ConVerT to Zero Signed
+ -- | Float ConVerT to Zero Signed
| FCVTZS Operand Operand
- -- Float ABSolute value
+ -- | Float ABSolute value
| FABS Operand Operand
-- | Floating-point fused multiply-add instructions
--
=====================================
compiler/GHC/CmmToAsm/RV64/Ppr.hs
=====================================
@@ -536,8 +536,6 @@ pprInstr platform instr = case instr of
EQ | isFloatOp l && isFloatOp r -> line $ binOp ("\tfeq." ++ floatOpPrecision platform l r)
NE | isIntOp l && isIntOp r -> lines_ [ subFor l r
, text "\tsnez" <+> pprOp platform o <> comma <+> pprOp platform o]
- -- feq.s a0,fa0,fa1
- -- xori a0,a0,1
NE | isFloatOp l && isFloatOp r -> lines_ [binOp ("\tfeq." ++ floatOpPrecision platform l r)
, text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"]
SLT -> lines_ [ sltFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r ]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3cc8710576b7d03710426eee519456657832903e...3b7865a75bbeb725b85bdfc718d5273f28726a8b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3cc8710576b7d03710426eee519456657832903e...3b7865a75bbeb725b85bdfc718d5273f28726a8b
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/20240630/65a671c0/attachment-0001.html>
More information about the ghc-commits
mailing list