From 11fdb7194f6a4a15f3897b0889e2f7648fecd594 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Sun, 30 Apr 2023 19:50:01 +0000 Subject: Double precision (64bit) float literals --- compiler/GHC/CmmToAsm/RISCV64/CodeGen.hs | 26 +++++++++++++++++++++++--- compiler/GHC/CmmToAsm/RISCV64/Instr.hs | 18 ++++++++++++++++++ compiler/GHC/CmmToAsm/RISCV64/Ppr.hs | 5 ++++- 3 files changed, 45 insertions(+), 4 deletions(-) diff --git a/compiler/GHC/CmmToAsm/RISCV64/CodeGen.hs b/compiler/GHC/CmmToAsm/RISCV64/CodeGen.hs index 77867bc5f5..97a83b6349 100644 --- a/compiler/GHC/CmmToAsm/RISCV64/CodeGen.hs +++ b/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" diff --git a/compiler/GHC/CmmToAsm/RISCV64/Instr.hs b/compiler/GHC/CmmToAsm/RISCV64/Instr.hs index c392454b89..2c1c087263 100644 --- a/compiler/GHC/CmmToAsm/RISCV64/Instr.hs +++ b/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 diff --git a/compiler/GHC/CmmToAsm/RISCV64/Ppr.hs b/compiler/GHC/CmmToAsm/RISCV64/Ppr.hs index 74f4526881..8f7bdaa630 100644 --- a/compiler/GHC/CmmToAsm/RISCV64/Ppr.hs +++ b/compiler/GHC/CmmToAsm/RISCV64/Ppr.hs @@ -147,13 +147,16 @@ 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 regNo)) = (text.regNoToName) regNo - pprReg (RegVirtual r) = panic $ "RISCV64.Ppr.ppr: Unexpected virtual register " ++ show r + pprReg virtualReg = (text . showPprUnsafe) virtualReg pprJ :: IsLine doc => Target -> doc pprJ (TBlock label) = text "\tj" <+> pprBlockId label -- cgit v1.2.1