[Git][ghc/ghc][wip/supersven/riscv-ncg] 4 commits: Little cleanup
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sun Apr 30 19:50:57 UTC 2023
Sven Tennie pushed to branch wip/supersven/riscv-ncg at Glasgow Haskell Compiler / GHC
Commits:
61bfc2b4 by Sven Tennie at 2023-04-28T17:10:48+00:00
Little cleanup
- - - - -
607ad010 by Sven Tennie at 2023-04-28T17:13:24+00:00
Connect mkVirtualReg
- - - - -
f9cf903c by Sven Tennie at 2023-04-28T19:08:41+00:00
Print registers with better names
- - - - -
11fdb719 by Sven Tennie at 2023-04-30T19:50:01+00:00
Double precision (64bit) float literals
- - - - -
5 changed files:
- compiler/GHC/CmmToAsm/RISCV64/CodeGen.hs
- compiler/GHC/CmmToAsm/RISCV64/Instr.hs
- compiler/GHC/CmmToAsm/RISCV64/Ppr.hs
- compiler/GHC/CmmToAsm/RISCV64/Regs.hs
- compiler/GHC/CmmToAsm/Reg/Target.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/RISCV64/CodeGen.hs
=====================================
@@ -24,6 +24,8 @@ import GHC.Utils.Panic
import GHC.Cmm.BlockId
import GHC.Utils.Trace
import Debug.Trace
+import Data.Word (Word64)
+import GHC.Float (castDoubleToWord64)
-- | Don't try to compile all GHC Cmm files in the beginning.
-- Ignore them. There's a flag to decide we really want to emit something.
@@ -111,7 +113,7 @@ stmtToInstrs stmt = do
a -> error $ "TODO: stmtToInstrs " ++ (showSDocUnsafe . pdoc platform) a
assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock
-assignReg_FltCode _ _ _ = error "TODO: assignReg_FltCode"
+assignReg_FltCode = assignReg_IntCode
-- TODO: Format parameter unused
assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock
@@ -122,7 +124,7 @@ assignReg_IntCode _ reg src
r <- getRegister src
return $ case r of
Any _ code -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL` code dst
- Fixed format freg fcode -> error "TODO: assignReg_IntCode - Fixed"
+ Fixed _format freg fcode -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL` (fcode `snocOL` MV dst freg)
-- | Grab the Reg for a CmmReg
getRegisterReg :: Platform -> CmmReg -> Reg
@@ -168,6 +170,17 @@ getRegister' config plat expr
CmmInt i W64 ->
return (Any II64 (\dst -> unitOL $ annExpr expr (LI dst i)))
CmmInt i w -> error ("TODO: getRegister' CmmInt " ++ show i ++ show w ++ " " ++show expr)
+ CmmFloat f W64 -> do
+ let word = castDoubleToWord64 (fromRational f) :: Word64
+ tmp <- getNewRegNat (intFormat W64)
+ return (Any FF64 (\dst -> toOL [
+ annExpr expr$
+ LI tmp (fromIntegral word),
+ FMV_D_X dst tmp
+ ]
+ )
+ )
+
CmmLabel lbl ->
return (Any II64 (\dst -> unitOL $ annExpr expr (LA dst lbl)))
e -> error ("TODO: getRegister' other " ++ show e)
@@ -313,9 +326,16 @@ genCCall target dest_regs arg_regs = do
code_r `snocOL`
ann (text "Pass gp argument: " <> ppr r) mov
passArguments gpRegs fpRegs args stackSpace (gpReg:accumRegs) accumCode'
+ passArguments gpRegs (fpReg:fpRegs) ((r, format, hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do
+ traceM $ "passArguments - float reg " ++ show r
+ let w = formatToWidth format
+ mov = FMV_D fpReg r
+ accumCode' = accumCode `appOL`
+ code_r `snocOL`
+ ann (text "Pass fp argument: " <> ppr r) mov
+ passArguments gpRegs fpRegs args stackSpace (fpReg:accumRegs) accumCode'
passArguments _ _ _ _ _ _ = error $ "TODO: passArguments"
-
readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM ([Reg], InstrBlock)
readResults _ _ [] accumRegs accumCode = return (accumRegs, accumCode)
readResults _ _ _ _ _ = error $ "TODO: readResults"
=====================================
compiler/GHC/CmmToAsm/RISCV64/Instr.hs
=====================================
@@ -47,6 +47,9 @@ data Instr
| JALR Reg
| -- copy register
MV Reg Reg
+ | FMV_S Reg Reg
+ | FMV_D Reg Reg
+ | FMV_D_X Reg Reg
data Target
= TBlock BlockId
@@ -105,6 +108,9 @@ regUsageOfInstr platform instr = case instr of
LI dst _ -> usage ([], [dst])
LA dst _ -> usage ([], [dst])
MV dst src -> usage ([src], [dst])
+ FMV_S dst src -> usage ([src], [dst])
+ FMV_D dst src -> usage ([src], [dst])
+ FMV_D_X dst src -> usage ([src], [dst])
-- Looks like J doesn't change registers (beside PC)
-- This might be wrong.
J {} -> none
@@ -147,6 +153,9 @@ patchRegsOfInstr instr env = case instr of
CALL {} -> instr
JALR reg -> JALR (env reg)
MV dst src -> MV (env dst) (env src)
+ FMV_S dst src -> FMV_S (env dst) (env src)
+ FMV_D dst src -> FMV_D (env dst) (env src)
+ FMV_D_X dst src -> FMV_D_X (env dst) (env src)
-- | Checks whether this instruction is a jump/branch instruction.
-- One that can change the flow of control in a way that the
@@ -159,6 +168,9 @@ isJumpishInstr DELTA {} = False
isJumpishInstr LDATA {} = False
isJumpishInstr NEWBLOCK {} = False
isJumpishInstr MV {} = False
+isJumpishInstr FMV_S {} = False
+isJumpishInstr FMV_D {} = False
+isJumpishInstr FMV_D_X {} = False
isJumpishInstr LA {} = False
isJumpishInstr LI {} = False
isJumpishInstr J {} = True
@@ -236,6 +248,9 @@ isMetaInstr instr =
LA {} -> False
J {} -> False
MV {} -> False
+ FMV_S {} -> False
+ FMV_D {} -> False
+ FMV_D_X {} -> False
CALL {} -> False
JALR {} -> False
@@ -265,6 +280,9 @@ takeRegRegMoveInstr LI {} = Nothing
takeRegRegMoveInstr LA {} = Nothing
takeRegRegMoveInstr J {} = Nothing
takeRegRegMoveInstr (MV dst src) = Just (src, dst)
+takeRegRegMoveInstr (FMV_S dst src) = Just (src, dst)
+takeRegRegMoveInstr (FMV_D dst src) = Just (src, dst)
+takeRegRegMoveInstr (FMV_D_X _ _) = Nothing -- Just (src, dst)
takeRegRegMoveInstr CALL {} = Nothing
takeRegRegMoveInstr JALR {} = Nothing
=====================================
compiler/GHC/CmmToAsm/RISCV64/Ppr.hs
=====================================
@@ -147,22 +147,27 @@ pprInstr platform instr = case instr of
LI reg immediate -> line $ pprLI reg immediate
LA reg label -> line $ text "\tla" <+> pprReg reg <> char ',' <+> pprAsmLabel platform label
MV dst src -> line $ text "\tmv" <+> pprReg dst <> char ',' <+> pprReg src
+ FMV_S dst src -> line $ text "\tfmv.s" <+> pprReg dst <> char ',' <+> pprReg src
+ FMV_D dst src -> line $ text "\tfmv.d" <+> pprReg dst <> char ',' <+> pprReg src
+ FMV_D_X dst src -> line $ text "\tfmv.d.x" <+> pprReg dst <> char ',' <+> pprReg src
where
pprLI :: IsLine doc => Reg -> Integer -> doc
pprLI reg immediate = text "\tli" <+> pprReg reg <> char ',' <+> (text.show) immediate
pprReg :: IsLine doc => Reg -> doc
- pprReg (RegReal (RealRegSingle r)) = text "x" <> (text.show) r
- pprReg (RegVirtual r) = panic $ "RISCV64.Ppr.ppr: Unexpected virtual register " ++ show r
+ pprReg (RegReal (RealRegSingle regNo)) = (text.regNoToName) regNo
+ pprReg virtualReg = (text . showPprUnsafe) virtualReg
pprJ :: IsLine doc => Target -> doc
pprJ (TBlock label) = text "\tj" <+> pprBlockId label
pprJ (TLabel label) = text "\tj" <+> pprAsmLabel platform label
+ pprJ (TReg reg) = panic $ "RISCV64 - Ppr.pprJ: Cannot J (jump) to registers. Requested register " ++ show reg
pprBlockId:: IsLine doc => BlockId -> doc
pprBlockId blockId = pprAsmLabel platform (mkLocalBlockLabel (getUnique blockId))
+
-- aarch64 GNU as uses // for comments.
asmComment :: SDoc -> SDoc
asmComment c = whenPprDebug $ text "#" <+> c
@@ -172,3 +177,70 @@ asmDoubleslashComment c = whenPprDebug $ text "//" <+> c
asmMultilineComment :: SDoc -> SDoc
asmMultilineComment c = whenPprDebug $ text "/*" $+$ c $+$ text "*/"
+
+regNoToName :: RegNo -> String
+regNoToName 0 = "zero"
+regNoToName 1 = "ra"
+regNoToName 2 = "sp"
+regNoToName 3 = "gp"
+regNoToName 4 = "tp"
+regNoToName 5 = "t0"
+regNoToName 6 = "t1"
+regNoToName 7 = "t2"
+regNoToName 8 = "s0"
+regNoToName 9 = "s1"
+regNoToName 10 = "a0"
+regNoToName 11 = "a1"
+regNoToName 12 = "a2"
+regNoToName 13 = "a3"
+regNoToName 14 = "a4"
+regNoToName 15 = "a5"
+regNoToName 16 = "a6"
+regNoToName 17 = "a7"
+regNoToName 18 = "s2"
+regNoToName 19 = "s3"
+regNoToName 20 = "s4"
+regNoToName 21 = "s5"
+regNoToName 22 = "s6"
+regNoToName 23 = "s7"
+regNoToName 24 = "s8"
+regNoToName 25 = "s9"
+regNoToName 26 = "s10"
+regNoToName 27 = "s11"
+regNoToName 28 = "t3"
+regNoToName 29 = "t4"
+regNoToName 30 = "t5"
+regNoToName 31 = "t6"
+regNoToName 32 = "ft0"
+regNoToName 33 = "ft1"
+regNoToName 34 = "ft2"
+regNoToName 35 = "ft3"
+regNoToName 36 = "ft4"
+regNoToName 37 = "ft5"
+regNoToName 38 = "ft6"
+regNoToName 39 = "ft7"
+regNoToName 40 = "fs0"
+regNoToName 41 = "fs1"
+regNoToName 42 = "fa0"
+regNoToName 43 = "fa1"
+regNoToName 44 = "fa2"
+regNoToName 45 = "fa3"
+regNoToName 46 = "fa4"
+regNoToName 47 = "fa5"
+regNoToName 48 = "fa6"
+regNoToName 49 = "fa7"
+regNoToName 50 = "fs2"
+regNoToName 51 = "fs3"
+regNoToName 52 = "fs4"
+regNoToName 53 = "fs5"
+regNoToName 54 = "fs6"
+regNoToName 55 = "fs7"
+regNoToName 56 = "fs8"
+regNoToName 57 = "fs9"
+regNoToName 58 = "fs10"
+regNoToName 59 = "fs11"
+regNoToName 60 = "ft8"
+regNoToName 61 = "ft9"
+regNoToName 62 = "ft10"
+regNoToName 63 = "ft11"
+regNoToName regNo = panic $ "RISCV64: regToName: Unknown register number " ++ show regNo
=====================================
compiler/GHC/CmmToAsm/RISCV64/Regs.hs
=====================================
@@ -29,6 +29,7 @@ mkVirtualReg u format
| not (isFloatFormat format) = VirtualRegI u
| otherwise
= case format of
- FF32 -> VirtualRegD u
- FF64 -> VirtualRegD u
- _ -> panic "RISCV64.mkVirtualReg"
+ -- TODO: Do we really need to widen FF32?
+ FF32 -> VirtualRegD u
+ FF64 -> VirtualRegD u
+ _ -> panic "RISCV64.mkVirtualReg"
=====================================
compiler/GHC/CmmToAsm/Reg/Target.hs
=====================================
@@ -34,6 +34,7 @@ import qualified GHC.CmmToAsm.X86.Regs as X86
import qualified GHC.CmmToAsm.X86.RegInfo as X86
import qualified GHC.CmmToAsm.PPC.Regs as PPC
import qualified GHC.CmmToAsm.AArch64.Regs as AArch64
+import qualified GHC.CmmToAsm.RISCV64.Regs as RISCV64
targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> Int
@@ -107,7 +108,7 @@ targetMkVirtualReg platform
ArchAlpha -> panic "targetMkVirtualReg ArchAlpha"
ArchMipseb -> panic "targetMkVirtualReg ArchMipseb"
ArchMipsel -> panic "targetMkVirtualReg ArchMipsel"
- ArchRISCV64 -> panic "targetMkVirtualReg ArchRISCV64"
+ ArchRISCV64 -> RISCV64.mkVirtualReg
ArchLoongArch64->panic "targetMkVirtualReg ArchLoongArch64"
ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript"
ArchWasm32 -> panic "targetMkVirtualReg ArchWasm32"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4481208a93ddfe0a1d7ba979aff80928b2955354...11fdb7194f6a4a15f3897b0889e2f7648fecd594
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4481208a93ddfe0a1d7ba979aff80928b2955354...11fdb7194f6a4a15f3897b0889e2f7648fecd594
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/20230430/5ec0bb48/attachment-0001.html>
More information about the ghc-commits
mailing list