Double precision (64bit) float literalswip/supersven/riscv-ncg

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