.gitlab/generate-ci/flake.lock

@@ -5,11 +5,11 @@
         "systems": "systems"
       },
       "locked": {
-        "lastModified": 1687709756,
-        "narHash": "sha256-Y5wKlQSkgEK2weWdOu4J3riRd+kV/VCgHsqLNTTWQ/0=",
+        "lastModified": 1710146030,
+        "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=",
         "owner": "numtide",
         "repo": "flake-utils",
-        "rev": "dbabf0ca0c0c4bce6ea5eaf65af5cb694d2082c7",
+        "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a",
         "type": "github"
       },
       "original": {
@@ -20,11 +20,11 @@
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1687886075,
-        "narHash": "sha256-PeayJDDDy+uw1Ats4moZnRdL1OFuZm1Tj+KiHlD67+o=",
+        "lastModified": 1724334015,
+        "narHash": "sha256-5sfvc0MswIRNdRWioUhG58rGKGn2o90Ck6l6ClpwQqA=",
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "a565059a348422af5af9026b5174dc5c0dcefdae",
+        "rev": "6d204f819efff3d552a88d0a44b5aaaee172b784",
         "type": "github"
       },
       "original": {

.gitlab/generate-ci/gen_ci.hs

@@ -155,6 +155,7 @@ data BuildConfig
                 , noSplitSections :: Bool
                 , validateNonmovingGc :: Bool
                 , textWithSIMDUTF :: Bool
+                , testsuiteUsePerf :: Bool
                 }
 
 -- Extra arguments to pass to ./configure due to the BuildConfig
@@ -216,6 +217,7 @@ vanilla = BuildConfig
   , noSplitSections = False
   , validateNonmovingGc = False
   , textWithSIMDUTF = False
+  , testsuiteUsePerf = False
   }
 
 splitSectionsBroken :: BuildConfig -> BuildConfig
@@ -268,6 +270,9 @@ tsan = vanilla { threadSanitiser = True }
 noTntc :: BuildConfig
 noTntc = vanilla { tablesNextToCode = False }
 
+usePerfProfilingTestsuite :: BuildConfig -> BuildConfig
+usePerfProfilingTestsuite bc = bc { testsuiteUsePerf = True }
+
 -----------------------------------------------------------------------------
 -- Platform specific variables
 -----------------------------------------------------------------------------
@@ -288,6 +293,9 @@ runnerTag _ _ = error "Invalid arch/opsys"
 tags :: Arch -> Opsys -> BuildConfig -> [String]
 tags arch opsys _bc = [runnerTag arch opsys] -- Tag for which runners we can use
 
+runnerPerfTag :: Arch -> Opsys -> String
+runnerPerfTag arch sys = runnerTag arch sys ++ "-perf"
+
 -- These names are used to find the docker image so they have to match what is
 -- in the docker registry.
 distroName :: LinuxDistro -> String
@@ -409,7 +417,7 @@ opsysVariables _ FreeBSD13 = mconcat
   , "GHC_VERSION" =: "9.6.4"
   , "CABAL_INSTALL_VERSION" =: "3.10.2.0"
   ]
-opsysVariables _ (Linux distro) = distroVariables distro
+opsysVariables arch (Linux distro) = distroVariables arch distro
 opsysVariables AArch64 (Darwin {}) =
   mconcat [ "NIX_SYSTEM" =: "aarch64-darwin"
           , "MACOSX_DEPLOYMENT_TARGET" =: "11.0"
@@ -441,25 +449,30 @@ opsysVariables _ (Windows {}) =
           , "GHC_VERSION" =: "9.6.4" ]
 opsysVariables _ _ = mempty
 
-alpineVariables = mconcat
+alpineVariables :: Arch -> Variables
+alpineVariables arch = mconcat $
   [ -- Due to #20266
     "CONFIGURE_ARGS" =: "--disable-ld-override"
   , "INSTALL_CONFIGURE_ARGS" =: "--disable-ld-override"
     -- encoding004: due to lack of locale support
     -- T10458, ghcilink002: due to #17869
   , "BROKEN_TESTS" =: "encoding004 T10458"
+  ] ++
+  [-- Bootstrap compiler has incorrectly configured target triple #25200
+    "CONFIGURE_ARGS" =: "--enable-ignore-build-platform-mismatch --build=aarch64-unknown-linux --host=aarch64-unknown-linux --target=aarch64-unknown-linux"
+    |  AArch64 <- [arch]
   ]
 
 
-distroVariables :: LinuxDistro -> Variables
-distroVariables Alpine312 = alpineVariables
-distroVariables Alpine318 = alpineVariables
-distroVariables Alpine320 = alpineVariables
-distroVariables Centos7 = mconcat [
+distroVariables :: Arch -> LinuxDistro -> Variables
+distroVariables arch Alpine312 = alpineVariables arch
+distroVariables arch Alpine318 = alpineVariables arch
+distroVariables arch Alpine320 = alpineVariables arch
+distroVariables _ Centos7 = mconcat [
     "HADRIAN_ARGS" =: "--docs=no-sphinx"
   , "BROKEN_TESTS" =: "T22012" -- due to #23979
   ]
-distroVariables Fedora33 = mconcat
+distroVariables _ Fedora33 = mconcat
   -- LLC/OPT do not work for some reason in our fedora images
   -- These tests fail with this error: T11649 T5681 T7571 T8131b
   -- +/opt/llvm/bin/opt: /lib64/libtinfo.so.5: no version information available (required by /opt/llvm/bin/opt)
@@ -467,7 +480,7 @@ distroVariables Fedora33 = mconcat
   [ "LLC" =: "/bin/false"
   , "OPT" =: "/bin/false"
   ]
-distroVariables _ = mempty
+distroVariables _ _ = mempty
 
 -----------------------------------------------------------------------------
 -- Cache settings, what to cache and when can we share the cache
@@ -770,6 +783,7 @@ job arch opsys buildConfig = NamedJob { name = jobName, jobInfo = Job {..} }
                 | validateNonmovingGc buildConfig
                 ]
         in "RUNTEST_ARGS" =: unwords runtestArgs
+      , if testsuiteUsePerf buildConfig then "RUNTEST_ARGS" =: "--config perf_path=perf" else mempty
       ]
 
     jobArtifacts = Artifacts
@@ -892,6 +906,12 @@ highCompression = addVariable "XZ_OPT" "-9"
 useHashUnitIds :: Job -> Job
 useHashUnitIds = addVariable "HADRIAN_ARGS" "--hash-unit-ids"
 
+-- | Change the tag of the job to make sure the job is scheduled on a
+-- runner that has the necessary capabilties to run the job with 'perf'
+-- profiling counters.
+perfProfilingJobTag :: Arch -> Opsys -> Job -> Job
+perfProfilingJobTag arch opsys j = j { jobTags = [ runnerPerfTag arch opsys ] }
+
 -- | Mark the validate job to run in fast-ci mode
 -- This is default way, to enable all jobs you have to apply the `full-ci` label.
 fastCI :: JobGroup Job -> JobGroup Job
@@ -995,6 +1015,8 @@ debian_x86 =
   , modifyNightlyJobs allowFailure (modifyValidateJobs (allowFailure . manual) tsan_jobs)
   , -- Nightly allowed to fail: #22343
     modifyNightlyJobs allowFailure (modifyValidateJobs manual (validateBuilds Amd64 (Linux validate_debian) noTntc))
+  -- Run the 'perf' profiling nightly job in the release config.
+  , perfProfilingJob Amd64 (Linux Debian12) releaseConfig
 
   , onlyRule LLVMBackend (validateBuilds Amd64 (Linux validate_debian) llvm)
   , addValidateRule TestPrimops (standardBuilds Amd64 (Linux validate_debian))
@@ -1005,6 +1027,12 @@ debian_x86 =
   where
     validate_debian = Debian12
 
+    perfProfilingJob arch sys buildConfig =
+        -- Rename the job to avoid conflicts
+        rename (<> "-perf")
+          $ modifyJobs (perfProfilingJobTag arch sys)
+          $ disableValidate (validateBuilds arch sys $ usePerfProfilingTestsuite buildConfig)
+
     tsan_jobs =
       modifyJobs
         ( addVariable "TSAN_OPTIONS" "suppressions=$CI_PROJECT_DIR/rts/.tsan-suppressions"

.gitlab/jobs.yaml

@@ -376,7 +376,7 @@
       "BIN_DIST_NAME": "ghc-aarch64-linux-alpine3_18-validate",
       "BROKEN_TESTS": "encoding004 T10458",
       "BUILD_FLAVOUR": "validate",
-      "CONFIGURE_ARGS": "--disable-ld-override --enable-strict-ghc-toolchain-check",
+      "CONFIGURE_ARGS": "--disable-ld-override --enable-ignore-build-platform-mismatch --build=aarch64-unknown-linux --host=aarch64-unknown-linux --target=aarch64-unknown-linux --enable-strict-ghc-toolchain-check",
       "INSTALL_CONFIGURE_ARGS": "--disable-ld-override --enable-strict-ghc-toolchain-check",
       "RUNTEST_ARGS": "",
       "TEST_ENV": "aarch64-linux-alpine3_18-validate",
@@ -1791,6 +1791,69 @@
       "XZ_OPT": "-9"
     }
   },
+  "nightly-x86_64-linux-deb12-release-perf": {
+    "after_script": [
+      ".gitlab/ci.sh save_cache",
+      ".gitlab/ci.sh save_test_output",
+      ".gitlab/ci.sh clean",
+      "cat ci_timings"
+    ],
+    "allow_failure": false,
+    "artifacts": {
+      "expire_in": "8 weeks",
+      "paths": [
+        "ghc-x86_64-linux-deb12-release.tar.xz",
+        "junit.xml",
+        "unexpected-test-output.tar.gz"
+      ],
+      "reports": {
+        "junit": "junit.xml"
+      },
+      "when": "always"
+    },
+    "cache": {
+      "key": "x86_64-linux-deb12-$CACHE_REV",
+      "paths": [
+        "cabal-cache",
+        "toolchain"
+      ]
+    },
+    "dependencies": [],
+    "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb12:$DOCKER_REV",
+    "needs": [
+      {
+        "artifacts": false,
+        "job": "hadrian-ghc-in-ghci"
+      }
+    ],
+    "rules": [
+      {
+        "if": "(\"true\" == \"true\") && ($RELEASE_JOB != \"yes\") && ($NIGHTLY)",
+        "when": "on_success"
+      }
+    ],
+    "script": [
+      "sudo chown ghc:ghc -R .",
+      ".gitlab/ci.sh setup",
+      ".gitlab/ci.sh configure",
+      ".gitlab/ci.sh build_hadrian",
+      ".gitlab/ci.sh test_hadrian"
+    ],
+    "stage": "full-build",
+    "tags": [
+      "x86_64-linux-perf"
+    ],
+    "variables": {
+      "BIGNUM_BACKEND": "gmp",
+      "BIN_DIST_NAME": "ghc-x86_64-linux-deb12-release",
+      "BUILD_FLAVOUR": "release",
+      "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
+      "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
+      "RUNTEST_ARGS": " --config perf_path=perf",
+      "TEST_ENV": "x86_64-linux-deb12-release",
+      "XZ_OPT": "-9"
+    }
+  },
   "nightly-x86_64-linux-deb12-unreg-validate": {
     "after_script": [
       ".gitlab/ci.sh save_cache",
@@ -2933,7 +2996,7 @@
       "BIN_DIST_NAME": "ghc-aarch64-linux-alpine3_18-release+no_split_sections",
       "BROKEN_TESTS": "encoding004 T10458",
       "BUILD_FLAVOUR": "release+no_split_sections",
-      "CONFIGURE_ARGS": "--disable-ld-override --enable-strict-ghc-toolchain-check",
+      "CONFIGURE_ARGS": "--disable-ld-override --enable-ignore-build-platform-mismatch --build=aarch64-unknown-linux --host=aarch64-unknown-linux --target=aarch64-unknown-linux --enable-strict-ghc-toolchain-check",
       "HADRIAN_ARGS": "--hash-unit-ids",
       "IGNORE_PERF_FAILURES": "all",
       "INSTALL_CONFIGURE_ARGS": "--disable-ld-override --enable-strict-ghc-toolchain-check",

.gitmodules

@@ -118,3 +118,6 @@
 [submodule "hadrian/vendored/Cabal"]
 	path = hadrian/vendored/Cabal
 	url = https://gitlab.haskell.org/ghc/packages/Cabal.git
+[submodule "libraries/file-io"]
+	path = libraries/file-io
+	url = https://gitlab.haskell.org/ghc/packages/file-io.git

CODEOWNERS

@@ -40,6 +40,7 @@
 /compiler/GHC/HsToCore/Foreign/Wasm.hs @TerrorJack
 /compiler/GHC/Tc/Deriv/            @RyanGlScott
 /compiler/GHC/CmmToAsm/            @simonmar @bgamari @AndreasK
+/compiler/GHC/CmmToAsm/RV64/       @supersven @angerman
 /compiler/GHC/CmmToAsm/Wasm/       @TerrorJack
 /compiler/GHC/CmmToLlvm/           @angerman
 /compiler/GHC/StgToCmm/            @simonmar @osa1

compiler/CodeGen.Platform.h

 
 import GHC.Cmm.Expr
 #if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \
-    || defined(MACHREGS_powerpc) || defined(MACHREGS_aarch64))
+    || defined(MACHREGS_powerpc) || defined(MACHREGS_aarch64) \
+    || defined(MACHREGS_riscv64))
 import GHC.Utils.Panic.Plain
 #endif
 import GHC.Platform.Reg
@@ -1120,6 +1121,105 @@ freeReg REG_D6    = False
 
 freeReg _ = True
 
+#elif defined(MACHREGS_riscv64)
+
+-- zero reg
+freeReg 0 = False
+-- link register
+freeReg 1 = False
+-- stack pointer
+freeReg 2 = False
+-- global pointer
+freeReg 3 = False
+-- thread pointer
+freeReg 4 = False
+-- frame pointer
+freeReg 8 = False
+-- made-up inter-procedural (ip) register
+-- See Note [The made-up RISCV64 IP register]
+freeReg 31 = False
+
+# if defined(REG_Base)
+freeReg REG_Base  = False
+# endif
+# if defined(REG_Sp)
+freeReg REG_Sp    = False
+# endif
+# if defined(REG_SpLim)
+freeReg REG_SpLim = False
+# endif
+# if defined(REG_Hp)
+freeReg REG_Hp    = False
+# endif
+# if defined(REG_HpLim)
+freeReg REG_HpLim = False
+# endif
+
+# if defined(REG_R1)
+freeReg REG_R1    = False
+# endif
+# if defined(REG_R2)
+freeReg REG_R2    = False
+# endif
+# if defined(REG_R3)
+freeReg REG_R3    = False
+# endif
+# if defined(REG_R4)
+freeReg REG_R4    = False
+# endif
+# if defined(REG_R5)
+freeReg REG_R5    = False
+# endif
+# if defined(REG_R6)
+freeReg REG_R6    = False
+# endif
+# if defined(REG_R7)
+freeReg REG_R7    = False
+# endif
+# if defined(REG_R8)
+freeReg REG_R8    = False
+# endif
+
+# if defined(REG_F1)
+freeReg REG_F1    = False
+# endif
+# if defined(REG_F2)
+freeReg REG_F2    = False
+# endif
+# if defined(REG_F3)
+freeReg REG_F3    = False
+# endif
+# if defined(REG_F4)
+freeReg REG_F4    = False
+# endif
+# if defined(REG_F5)
+freeReg REG_F5    = False
+# endif
+# if defined(REG_F6)
+freeReg REG_F6    = False
+# endif
+
+# if defined(REG_D1)
+freeReg REG_D1    = False
+# endif
+# if defined(REG_D2)
+freeReg REG_D2    = False
+# endif
+# if defined(REG_D3)
+freeReg REG_D3    = False
+# endif
+# if defined(REG_D4)
+freeReg REG_D4    = False
+# endif
+# if defined(REG_D5)
+freeReg REG_D5    = False
+# endif
+# if defined(REG_D6)
+freeReg REG_D6    = False
+# endif
+
+freeReg _ = True
+
 #else
 
 freeReg = panic "freeReg not defined for this platform"

compiler/GHC/Builtin/primops.txt.pp

@@ -1925,7 +1925,25 @@ primop  MutableByteArrayIsPinnedOp "isMutableByteArrayPinned#" GenPrimOp
 
 primop  ByteArrayIsPinnedOp "isByteArrayPinned#" GenPrimOp
    ByteArray# -> Int#
-   {Determine whether a 'ByteArray#' is guaranteed not to move during GC.}
+   {Determine whether a 'ByteArray#' is guaranteed not to move.}
+   with out_of_line = True
+
+primop  ByteArrayIsWeaklyPinnedOp "isByteArrayWeaklyPinned#" GenPrimOp
+   ByteArray# -> Int#
+   {Similar to 'isByteArrayPinned#'. Weakly pinned byte arrays are allowed
+    to be copied into compact regions by the user, potentially invalidating
+    the results of earlier calls to 'byteArrayContents#'.
+
+    See the section `Pinned Byte Arrays` in the user guide for more information.
+
+    This function also returns true for regular pinned bytearrays.
+   }
+   with out_of_line = True
+
+primop  MutableByteArrayIsWeaklyPinnedOp "isMutableByteArrayWeaklyPinned#" GenPrimOp
+   MutableByteArray# s -> Int#
+   { 'isByteArrayWeaklyPinned#' but for mutable arrays.
+   }
    with out_of_line = True
 
 primop  ByteArrayContents_Char "byteArrayContents#" GenPrimOp

compiler/GHC/Cmm/CLabel.hs

@@ -1709,6 +1709,8 @@ pprDynamicLinkerAsmLabel !platform dllInfo ppLbl =
       | platformArch platform == ArchAArch64
       = ppLbl
 
+      | platformArch platform == ArchRISCV64
+      = ppLbl
 
       | platformArch platform == ArchX86_64
       = case dllInfo of

compiler/GHC/CmmToAsm.hs

@@ -67,6 +67,7 @@ import qualified GHC.CmmToAsm.X86   as X86
 import qualified GHC.CmmToAsm.PPC   as PPC
 import qualified GHC.CmmToAsm.AArch64 as AArch64
 import qualified GHC.CmmToAsm.Wasm as Wasm32
+import qualified GHC.CmmToAsm.RV64  as RV64
 
 import GHC.CmmToAsm.Reg.Liveness
 import qualified GHC.CmmToAsm.Reg.Linear                as Linear
@@ -148,7 +149,7 @@ nativeCodeGen logger ts config modLoc h us cmms
       ArchAlpha     -> panic "nativeCodeGen: No NCG for Alpha"
       ArchMipseb    -> panic "nativeCodeGen: No NCG for mipseb"
       ArchMipsel    -> panic "nativeCodeGen: No NCG for mipsel"
-      ArchRISCV64   -> panic "nativeCodeGen: No NCG for RISCV64"
+      ArchRISCV64   -> nCG' (RV64.ncgRV64 config)
       ArchLoongArch64->panic "nativeCodeGen: No NCG for LoongArch64"
       ArchUnknown   -> panic "nativeCodeGen: No NCG for unknown arch"
       ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript"

compiler/GHC/CmmToAsm/AArch64/CodeGen.hs

@@ -1990,9 +1990,13 @@ genCCall target dest_regs arg_regs = do
         MO_SubIntC    _w -> unsupported mop
 
         -- Memory Ordering
-        MO_AcquireFence     ->  return (unitOL DMBISH)
-        MO_ReleaseFence     ->  return (unitOL DMBISH)
-        MO_SeqCstFence      ->  return (unitOL DMBISH)
+        -- Set flags according to their C pendants (stdatomic.h):
+        -- atomic_thread_fence(memory_order_acquire); // -> dmb ishld
+        MO_AcquireFence     ->  return . unitOL $ DMBISH DmbLoad
+        -- atomic_thread_fence(memory_order_release); // -> dmb ish
+        MO_ReleaseFence     ->  return . unitOL $ DMBISH DmbLoadStore
+        -- atomic_thread_fence(memory_order_seq_cst); // -> dmb ish
+        MO_SeqCstFence      ->  return . unitOL $ DMBISH DmbLoadStore
         MO_Touch            ->  return nilOL -- Keep variables live (when using interior pointers)
         -- Prefetch
         MO_Prefetch_Data _n -> return nilOL -- Prefetch hint.

compiler/GHC/CmmToAsm/AArch64/Instr.hs

@@ -134,7 +134,7 @@ regUsageOfInstr platform instr = case instr of
   LDAR _ dst src           -> usage (regOp src, regOp dst)
 
   -- 8. Synchronization Instructions -------------------------------------------
-  DMBISH                   -> usage ([], [])
+  DMBISH _                 -> usage ([], [])
 
   -- 9. Floating Point Instructions --------------------------------------------
   FMOV dst src             -> usage (regOp src, regOp dst)
@@ -281,7 +281,7 @@ patchRegsOfInstr instr env = case instr of
     LDAR f o1 o2   -> LDAR f (patchOp o1) (patchOp o2)
 
     -- 8. Synchronization Instructions -----------------------------------------
-    DMBISH         -> DMBISH
+    DMBISH c       -> DMBISH c
 
     -- 9. Floating Point Instructions ------------------------------------------
     FMOV o1 o2     -> FMOV (patchOp o1) (patchOp o2)
@@ -649,7 +649,7 @@ data Instr
     | BCOND Cond Target   -- branch with condition. b.<cond>
 
     -- 8. Synchronization Instructions -----------------------------------------
-    | DMBISH
+    | DMBISH DMBISHFlags
     -- 9. Floating Point Instructions
     -- move to/from general purpose <-> floating, or floating to floating
     | FMOV Operand Operand
@@ -672,6 +672,9 @@ data Instr
     -- - fnmadd: d = - r1 * r2 - r3
     | FMA FMASign Operand Operand Operand Operand
 
+data DMBISHFlags = DmbLoad | DmbLoadStore
+  deriving (Eq, Show)
+
 instrCon :: Instr -> String
 instrCon i =
     case i of

compiler/GHC/CmmToAsm/AArch64/Ppr.hs

@@ -527,7 +527,8 @@ pprInstr platform instr = case instr of
   LDAR _f o1 o2 -> op2 (text "\tldar") o1 o2
 
   -- 8. Synchronization Instructions -------------------------------------------
-  DMBISH -> line $ text "\tdmb ish"
+  DMBISH DmbLoadStore -> line $ text "\tdmb ish"
+  DMBISH DmbLoad -> line $ text "\tdmb ishld"
 
   -- 9. Floating Point Instructions --------------------------------------------
   FMOV o1 o2 -> op2 (text "\tfmov") o1 o2

compiler/GHC/CmmToAsm/Dwarf/Constants.hs

@@ -240,6 +240,7 @@ dwarfRegNo p r = case platformArch p of
     | r == xmm15 -> 32
   ArchPPC_64 _ -> fromIntegral $ toRegNo r
   ArchAArch64  -> fromIntegral $ toRegNo r
+  ArchRISCV64  -> fromIntegral $ toRegNo r
   _other -> error "dwarfRegNo: Unsupported platform or unknown register!"
 
 -- | Virtual register number to use for return address.
@@ -252,5 +253,6 @@ dwarfReturnRegNo p
     ArchX86    -> 8  -- eip
     ArchX86_64 -> 16 -- rip
     ArchPPC_64 ELF_V2 -> 65 -- lr (link register)
-    ArchAArch64-> 30
+    ArchAArch64 -> 30
+    ArchRISCV64 -> 1 -- ra (return address)
     _other     -> error "dwarfReturnRegNo: Unsupported platform!"

compiler/GHC/CmmToAsm/PIC.hs

@@ -132,6 +132,11 @@ cmmMakeDynamicReference config referenceKind lbl
               addImport symbolPtr
               return $ cmmMakePicReference config symbolPtr
 
+        AccessViaSymbolPtr | ArchRISCV64 <- platformArch platform -> do
+              let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl
+              addImport symbolPtr
+              return $ cmmMakePicReference config symbolPtr
+
         AccessViaSymbolPtr -> do
               let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl
               addImport symbolPtr
@@ -164,6 +169,10 @@ cmmMakePicReference config lbl
   | ArchAArch64 <- platformArch platform
   = CmmLit $ CmmLabel lbl
 
+  -- as on AArch64, there's no pic base register.
+  | ArchRISCV64 <- platformArch platform
+  = CmmLit $ CmmLabel lbl
+
   | OSAIX <- platformOS platform
   = CmmMachOp (MO_Add W32)
           [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform))

compiler/GHC/CmmToAsm/RV64.hs

+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-- | Native code generator for RiscV64 architectures
+module GHC.CmmToAsm.RV64 (ncgRV64) where
+
+import GHC.CmmToAsm.Config
+import GHC.CmmToAsm.Instr
+import GHC.CmmToAsm.Monad
+import GHC.CmmToAsm.RV64.CodeGen qualified as RV64
+import GHC.CmmToAsm.RV64.Instr qualified as RV64
+import GHC.CmmToAsm.RV64.Ppr qualified as RV64
+import GHC.CmmToAsm.RV64.RegInfo qualified as RV64
+import GHC.CmmToAsm.RV64.Regs qualified as RV64
+import GHC.CmmToAsm.Types
+import GHC.Prelude
+import GHC.Utils.Outputable (ftext)
+
+ncgRV64 :: NCGConfig -> NcgImpl RawCmmStatics RV64.Instr RV64.JumpDest
+ncgRV64 config =
+  NcgImpl
+    { ncgConfig = config,
+      cmmTopCodeGen = RV64.cmmTopCodeGen,
+      generateJumpTableForInstr = RV64.generateJumpTableForInstr config,
+      getJumpDestBlockId = RV64.getJumpDestBlockId,
+      canShortcut = RV64.canShortcut,
+      shortcutStatics = RV64.shortcutStatics,
+      shortcutJump = RV64.shortcutJump,
+      pprNatCmmDeclS = RV64.pprNatCmmDecl config,
+      pprNatCmmDeclH = RV64.pprNatCmmDecl config,
+      maxSpillSlots = RV64.maxSpillSlots config,
+      allocatableRegs = RV64.allocatableRegs platform,
+      ncgAllocMoreStack = RV64.allocMoreStack platform,
+      ncgMakeFarBranches = RV64.makeFarBranches,
+      extractUnwindPoints = const [],
+      invertCondBranches = \_ _ -> id
+    }
+  where
+    platform = ncgPlatform config
+
+-- | `Instruction` instance for RV64
+instance Instruction RV64.Instr where
+  regUsageOfInstr = RV64.regUsageOfInstr
+  patchRegsOfInstr = RV64.patchRegsOfInstr
+  isJumpishInstr = RV64.isJumpishInstr
+  canFallthroughTo = RV64.canFallthroughTo
+  jumpDestsOfInstr = RV64.jumpDestsOfInstr
+  patchJumpInstr = RV64.patchJumpInstr
+  mkSpillInstr = RV64.mkSpillInstr
+  mkLoadInstr = RV64.mkLoadInstr
+  takeDeltaInstr = RV64.takeDeltaInstr
+  isMetaInstr = RV64.isMetaInstr
+  mkRegRegMoveInstr _ = RV64.mkRegRegMoveInstr
+  takeRegRegMoveInstr = RV64.takeRegRegMoveInstr
+  mkJumpInstr = RV64.mkJumpInstr
+  mkStackAllocInstr = RV64.mkStackAllocInstr
+  mkStackDeallocInstr = RV64.mkStackDeallocInstr
+  mkComment = pure . RV64.COMMENT . ftext
+  pprInstr = RV64.pprInstr

compiler/GHC/CmmToAsm/RV64/Cond.hs

+module GHC.CmmToAsm.RV64.Cond
+  ( Cond (..),
+  )
+where
+
+import GHC.Prelude hiding (EQ)
+
+-- | Condition codes.
+--
+-- Used in conditional branches and bit setters. According to the available
+-- instruction set, some conditions are encoded as their negated opposites. I.e.
+-- these are logical things that don't necessarily map 1:1 to hardware/ISA.
+data Cond
+  = -- | int and float
+    EQ
+  | -- | int and float
+    NE
+  | -- | signed less than
+    SLT
+  | -- | signed less than or equal
+    SLE
+  | -- | signed greater than or equal
+    SGE
+  | -- | signed greater than
+    SGT
+  | -- | unsigned less than
+    ULT
+  | -- | unsigned less than or equal
+    ULE
+  | -- | unsigned greater than or equal
+    UGE
+  | -- | unsigned greater than
+    UGT
+  | -- | floating point instruction @flt@
+    FLT
+  | -- | floating point instruction @fle@
+    FLE
+  | -- | floating point instruction @fge@
+    FGE
+  | -- | floating point instruction @fgt@
+    FGT
+  deriving (Eq, Show)

compiler/GHC/CmmToAsm/RV64/Instr.hs

+-- All instructions will be rendered eventually. Thus, there's no benefit in
+-- being lazy in data types.
+{-# LANGUAGE StrictData #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module GHC.CmmToAsm.RV64.Instr where
+
+import Data.Maybe
+import GHC.Cmm
+import GHC.Cmm.BlockId
+import GHC.Cmm.CLabel
+import GHC.Cmm.Dataflow.Label
+import GHC.CmmToAsm.Config
+import GHC.CmmToAsm.Format
+import GHC.CmmToAsm.Instr (RegUsage (..))
+import GHC.CmmToAsm.RV64.Cond
+import GHC.CmmToAsm.RV64.Regs
+import GHC.CmmToAsm.Types
+import GHC.CmmToAsm.Utils
+import GHC.Data.FastString (LexicalFastString)
+import GHC.Platform
+import GHC.Platform.Reg
+import GHC.Platform.Regs
+import GHC.Prelude
+import GHC.Stack
+import GHC.Types.Unique.Supply
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+
+-- | Stack frame header size in bytes.
+--
+-- The stack frame header is made of the values that are always saved
+-- (regardless of the context.) It consists of the saved return address and a
+-- pointer to the previous frame. Thus, its size is two stack frame slots which
+-- equals two addresses/words (2 * 8 byte).
+stackFrameHeaderSize :: Int
+stackFrameHeaderSize = 2 * spillSlotSize
+
+-- | All registers are 8 byte wide.
+spillSlotSize :: Int
+spillSlotSize = 8
+
+-- | The number of bytes that the stack pointer should be aligned to.
+stackAlign :: Int
+stackAlign = 16
+
+-- | The number of spill slots available without allocating more.
+maxSpillSlots :: NCGConfig -> Int
+maxSpillSlots config =
+  ( (ncgSpillPreallocSize config - stackFrameHeaderSize)
+      `div` spillSlotSize
+  )
+    - 1
+
+-- | Convert a spill slot number to a *byte* offset.
+spillSlotToOffset :: Int -> Int
+spillSlotToOffset slot =
+  stackFrameHeaderSize + spillSlotSize * slot
+
+instance Outputable RegUsage where
+  ppr (RU reads writes) = text "RegUsage(reads:" <+> ppr reads <> comma <+> text "writes:" <+> ppr writes <> char ')'
+
+-- | Get the registers that are being used by this instruction.
+-- regUsage doesn't need to do any trickery for jumps and such.
+-- Just state precisely the regs read and written by that insn.
+-- The consequences of control flow transfers, as far as register
+-- allocation goes, are taken care of by the register allocator.
+--
+-- RegUsage = RU [<read regs>] [<write regs>]
+regUsageOfInstr :: Platform -> Instr -> RegUsage
+regUsageOfInstr platform instr = case instr of
+  ANN _ i -> regUsageOfInstr platform i
+  COMMENT {} -> usage ([], [])
+  MULTILINE_COMMENT {} -> usage ([], [])
+  PUSH_STACK_FRAME -> usage ([], [])
+  POP_STACK_FRAME -> usage ([], [])
+  LOCATION {} -> usage ([], [])
+  DELTA {} -> usage ([], [])
+  ADD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
+  MUL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
+  NEG dst src -> usage (regOp src, regOp dst)
+  MULH dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
+  DIV dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
+  REM dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
+  REMU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
+  SUB dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
+  DIVU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
+  AND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
+  OR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
+  SRA dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
+  XOR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
+  SLL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
+  SRL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
+  MOV dst src -> usage (regOp src, regOp dst)
+  -- ORI's third operand is always an immediate
+  ORI dst src1 _ -> usage (regOp src1, regOp dst)
+  XORI dst src1 _ -> usage (regOp src1, regOp dst)
+  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 (t : ps, callerSavedRegisters)
+  CSET dst l r _ -> usage (regOp l ++ regOp r, regOp dst)
+  STR _ src dst -> usage (regOp src ++ regOp dst, [])
+  LDR _ dst src -> usage (regOp src, regOp dst)
+  LDRU _ dst src -> usage (regOp src, regOp dst)
+  FENCE _ _ -> usage ([], [])
+  FCVT _variant dst src -> usage (regOp src, regOp dst)
+  FABS dst src -> usage (regOp src, regOp dst)
+  FMA _ dst src1 src2 src3 ->
+    usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)
+  _ -> panic $ "regUsageOfInstr: " ++ instrCon instr
+  where
+    -- filtering the usage is necessary, otherwise the register
+    -- allocator will try to allocate pre-defined fixed stg
+    -- registers as well, as they show up.
+    usage :: ([Reg], [Reg]) -> RegUsage
+    usage (srcRegs, dstRegs) =
+      RU
+        (filter (interesting platform) srcRegs)
+        (filter (interesting platform) dstRegs)
+
+    regAddr :: AddrMode -> [Reg]
+    regAddr (AddrRegImm r1 _imm) = [r1]
+    regAddr (AddrReg r1) = [r1]
+
+    regOp :: Operand -> [Reg]
+    regOp (OpReg _w r1) = [r1]
+    regOp (OpAddr a) = regAddr a
+    regOp (OpImm _imm) = []
+
+    regTarget :: Target -> [Reg]
+    regTarget (TBlock _bid) = []
+    regTarget (TReg r1) = [r1]
+
+    -- Is this register interesting for the register allocator?
+    interesting :: Platform -> Reg -> Bool
+    interesting _ (RegVirtual _) = True
+    interesting platform (RegReal (RealRegSingle i)) = freeReg platform i
+
+-- | Caller-saved registers (according to calling convention)
+--
+-- These registers may be clobbered after a jump.
+callerSavedRegisters :: [Reg]
+callerSavedRegisters =
+  [regSingle raRegNo]
+    ++ map regSingle [t0RegNo .. t2RegNo]
+    ++ map regSingle [a0RegNo .. a7RegNo]
+    ++ map regSingle [t3RegNo .. t6RegNo]
+    ++ map regSingle [ft0RegNo .. ft7RegNo]
+    ++ map regSingle [fa0RegNo .. fa7RegNo]
+
+-- | Apply a given mapping to all the register references in this instruction.
+patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
+patchRegsOfInstr instr env = case instr of
+  ANN d i -> ANN d (patchRegsOfInstr i env)
+  COMMENT {} -> instr
+  MULTILINE_COMMENT {} -> instr
+  PUSH_STACK_FRAME -> instr
+  POP_STACK_FRAME -> instr
+  LOCATION {} -> instr
+  DELTA {} -> instr
+  ADD o1 o2 o3 -> ADD (patchOp o1) (patchOp o2) (patchOp o3)
+  MUL o1 o2 o3 -> MUL (patchOp o1) (patchOp o2) (patchOp o3)
+  NEG o1 o2 -> NEG (patchOp o1) (patchOp o2)
+  MULH o1 o2 o3 -> MULH (patchOp o1) (patchOp o2) (patchOp o3)
+  DIV o1 o2 o3 -> DIV (patchOp o1) (patchOp o2) (patchOp o3)
+  REM o1 o2 o3 -> REM (patchOp o1) (patchOp o2) (patchOp o3)
+  REMU o1 o2 o3 -> REMU (patchOp o1) (patchOp o2) (patchOp o3)
+  SUB o1 o2 o3 -> SUB (patchOp o1) (patchOp o2) (patchOp o3)
+  DIVU o1 o2 o3 -> DIVU (patchOp o1) (patchOp o2) (patchOp o3)
+  AND o1 o2 o3 -> AND (patchOp o1) (patchOp o2) (patchOp o3)
+  OR o1 o2 o3 -> OR (patchOp o1) (patchOp o2) (patchOp o3)
+  SRA o1 o2 o3 -> SRA (patchOp o1) (patchOp o2) (patchOp o3)
+  XOR o1 o2 o3 -> XOR (patchOp o1) (patchOp o2) (patchOp o3)
+  SLL o1 o2 o3 -> SLL (patchOp o1) (patchOp o2) (patchOp o3)
+  SRL o1 o2 o3 -> SRL (patchOp o1) (patchOp o2) (patchOp o3)
+  MOV o1 o2 -> MOV (patchOp o1) (patchOp o2)
+  -- o3 cannot be a register for ORI (always an immediate)
+  ORI o1 o2 o3 -> ORI (patchOp o1) (patchOp o2) (patchOp o3)
+  XORI o1 o2 o3 -> XORI (patchOp o1) (patchOp o2) (patchOp o3)
+  J_TBL ids mbLbl t -> J_TBL ids mbLbl (env t)
+  B t -> B (patchTarget t)
+  BL t ps -> BL (patchReg t) ps
+  BCOND c o1 o2 t -> BCOND c (patchOp o1) (patchOp o2) (patchTarget t)
+  CSET o l r c -> CSET (patchOp o) (patchOp l) (patchOp r) c
+  STR f o1 o2 -> STR f (patchOp o1) (patchOp o2)
+  LDR f o1 o2 -> LDR f (patchOp o1) (patchOp o2)
+  LDRU f o1 o2 -> LDRU f (patchOp o1) (patchOp o2)
+  FENCE o1 o2 -> FENCE o1 o2
+  FCVT variant o1 o2 -> FCVT variant (patchOp o1) (patchOp o2)
+  FABS o1 o2 -> FABS (patchOp o1) (patchOp o2)
+  FMA s o1 o2 o3 o4 ->
+    FMA s (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)
+  _ -> panic $ "patchRegsOfInstr: " ++ instrCon instr
+  where
+    patchOp :: Operand -> Operand
+    patchOp (OpReg w r) = OpReg w (env r)
+    patchOp (OpAddr a) = OpAddr (patchAddr a)
+    patchOp opImm = opImm
+
+    patchTarget :: Target -> Target
+    patchTarget (TReg r) = TReg (env r)
+    patchTarget tBlock = tBlock
+
+    patchAddr :: AddrMode -> AddrMode
+    patchAddr (AddrRegImm r1 imm) = AddrRegImm (env r1) imm
+    patchAddr (AddrReg r) = AddrReg (env r)
+
+    patchReg :: Reg -> Reg
+    patchReg = env
+
+-- | Checks whether this instruction is a jump/branch instruction.
+--
+-- One that can change the flow of control in a way that the
+-- register allocator needs to worry about.
+isJumpishInstr :: Instr -> Bool
+isJumpishInstr instr = case instr of
+  ANN _ i -> isJumpishInstr i
+  J_TBL {} -> True
+  B {} -> True
+  BL {} -> True
+  BCOND {} -> True
+  _ -> False
+
+canFallthroughTo :: Instr -> BlockId -> Bool
+canFallthroughTo insn bid =
+  case insn of
+    B (TBlock target) -> bid == target
+    BCOND _ _ _ (TBlock target) -> bid == target
+    J_TBL targets _ _ -> all isTargetBid targets
+    _ -> False
+  where
+    isTargetBid target = case target of
+      Nothing -> True
+      Just target -> target == bid
+
+-- | Get the `BlockId`s of the jump destinations (if any)
+jumpDestsOfInstr :: Instr -> [BlockId]
+jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i
+jumpDestsOfInstr (J_TBL ids _mbLbl _r) = catMaybes ids
+jumpDestsOfInstr (B t) = [id | TBlock id <- [t]]
+jumpDestsOfInstr (BCOND _ _ _ t) = [id | TBlock id <- [t]]
+jumpDestsOfInstr _ = []
+
+-- | Change the destination of this (potential) jump instruction.
+--
+-- Used in the linear allocator when adding fixup blocks for join
+-- points.
+patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr
+patchJumpInstr instr patchF =
+  case instr of
+    ANN d i -> ANN d (patchJumpInstr i patchF)
+    J_TBL ids mbLbl r -> J_TBL (map (fmap patchF) ids) mbLbl r
+    B (TBlock bid) -> B (TBlock (patchF bid))
+    BCOND c o1 o2 (TBlock bid) -> BCOND c o1 o2 (TBlock (patchF bid))
+    _ -> panic $ "patchJumpInstr: " ++ instrCon instr
+
+-- -----------------------------------------------------------------------------
+-- Note [RISCV64 Spills and Reloads]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- We reserve @RESERVED_C_STACK_BYTES@ on the C stack for spilling and reloading
+-- registers. The load and store instructions of RISCV64 address with a signed
+-- 12-bit immediate + a register; machine stackpointer (sp/x2) in this case.
+--
+-- The @RESERVED_C_STACK_BYTES@ is 16k, so we can't always address into it in a
+-- single load/store instruction. There are offsets to sp (not to be confused
+-- with STG's SP!) which need a register to be calculated.
+--
+-- Using sp to compute the offset will violate assumptions about the stack pointer
+-- pointing to the top of the stack during signal handling.  As we can't force
+-- every signal to use its own stack, we have to ensure that the stack pointer
+-- always points to the top of the stack, and we can't use it for computation.
+--
+-- So, we reserve one register (ip) for this purpose (and other, unrelated
+-- intermediate operations.) See Note [The made-up RISCV64 IP register]
+
+-- | Generate instructions to spill a register into a spill slot.
+mkSpillInstr ::
+  (HasCallStack) =>
+  NCGConfig ->
+  -- | register to spill
+  Reg ->
+  -- | current stack delta
+  Int ->
+  -- | spill slot to use
+  Int ->
+  [Instr]
+mkSpillInstr _config reg delta slot =
+  case off - delta of
+    imm | fitsIn12bitImm imm -> [mkStrSpImm imm]
+    imm ->
+      [ movImmToIp imm,
+        addSpToIp,
+        mkStrIp
+      ]
+  where
+    fmt = case reg of
+      RegReal (RealRegSingle n) | n < d0RegNo -> II64
+      _ -> FF64
+    mkStrSpImm imm =
+      ANN (text "Spill@" <> int (off - delta))
+        $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm)))
+    movImmToIp imm =
+      ANN (text "Spill: IP <- " <> int imm)
+        $ MOV ip (OpImm (ImmInt imm))
+    addSpToIp =
+      ANN (text "Spill: IP <- SP + IP ")
+        $ ADD ip ip sp
+    mkStrIp =
+      ANN (text "Spill@" <> int (off - delta))
+        $ STR fmt (OpReg W64 reg) (OpAddr (AddrReg ipReg))
+
+    off = spillSlotToOffset slot
+
+-- | Generate instructions to load a register from a spill slot.
+mkLoadInstr ::
+  NCGConfig ->
+  -- | register to load
+  Reg ->
+  -- | current stack delta
+  Int ->
+  -- | spill slot to use
+  Int ->
+  [Instr]
+mkLoadInstr _config reg delta slot =
+  case off - delta of
+    imm | fitsIn12bitImm imm -> [mkLdrSpImm imm]
+    imm ->
+      [ movImmToIp imm,
+        addSpToIp,
+        mkLdrIp
+      ]
+  where
+    fmt = case reg of
+      RegReal (RealRegSingle n) | n < d0RegNo -> II64
+      _ -> FF64
+    mkLdrSpImm imm =
+      ANN (text "Reload@" <> int (off - delta))
+        $ LDR fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm)))
+    movImmToIp imm =
+      ANN (text "Reload: IP <- " <> int imm)
+        $ MOV ip (OpImm (ImmInt imm))
+    addSpToIp =
+      ANN (text "Reload: IP <- SP + IP ")
+        $ ADD ip ip sp
+    mkLdrIp =
+      ANN (text "Reload@" <> int (off - delta))
+        $ LDR fmt (OpReg W64 reg) (OpAddr (AddrReg ipReg))
+
+    off = spillSlotToOffset slot
+
+-- | See if this instruction is telling us the current C stack delta
+takeDeltaInstr :: Instr -> Maybe Int
+takeDeltaInstr (ANN _ i) = takeDeltaInstr i
+takeDeltaInstr (DELTA i) = Just i
+takeDeltaInstr _ = Nothing
+
+-- | Not real instructions.  Just meta data
+isMetaInstr :: Instr -> Bool
+isMetaInstr instr =
+  case instr of
+    ANN _ i -> isMetaInstr i
+    COMMENT {} -> True
+    MULTILINE_COMMENT {} -> True
+    LOCATION {} -> True
+    LDATA {} -> True
+    NEWBLOCK {} -> True
+    DELTA {} -> True
+    PUSH_STACK_FRAME -> True
+    POP_STACK_FRAME -> True
+    _ -> False
+
+-- | Copy the value in a register to another one.
+--
+-- Must work for all register classes.
+mkRegRegMoveInstr :: Reg -> Reg -> Instr
+mkRegRegMoveInstr src dst = ANN desc instr
+  where
+    desc = text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst
+    instr = MOV (operandFromReg dst) (operandFromReg src)
+
+-- | Take the source and destination from this (potential) reg -> reg move instruction
+--
+-- We have to be a bit careful here: A `MOV` can also mean an implicit
+-- conversion. This case is filtered out.
+takeRegRegMoveInstr :: Instr -> Maybe (Reg, Reg)
+takeRegRegMoveInstr (MOV (OpReg width dst) (OpReg width' src))
+  | width == width' && (isFloatReg dst == isFloatReg src) = pure (src, dst)
+takeRegRegMoveInstr _ = Nothing
+
+-- | Make an unconditional jump instruction.
+mkJumpInstr :: BlockId -> [Instr]
+mkJumpInstr = pure . B . TBlock
+
+-- | Decrement @sp@ to allocate stack space.
+--
+-- The stack grows downwards, so we decrement the stack pointer by @n@ (bytes).
+-- This is dual to `mkStackDeallocInstr`. @sp@ is the RISCV stack pointer, not
+-- to be confused with the STG stack pointer.
+mkStackAllocInstr :: Platform -> Int -> [Instr]
+mkStackAllocInstr _platform = moveSp . negate
+
+-- | Increment SP to deallocate stack space.
+--
+-- The stack grows downwards, so we increment the stack pointer by @n@ (bytes).
+-- This is dual to `mkStackAllocInstr`. @sp@ is the RISCV stack pointer, not to
+-- be confused with the STG stack pointer.
+mkStackDeallocInstr :: Platform -> Int -> [Instr]
+mkStackDeallocInstr _platform = moveSp
+
+moveSp :: Int -> [Instr]
+moveSp n
+  | n == 0 = []
+  | n /= 0 && fitsIn12bitImm n = pure . ANN desc $ ADD sp sp (OpImm (ImmInt n))
+  | otherwise =
+      -- This ends up in three effective instructions. We could get away with
+      -- two for intMax12bit < n < 3 * intMax12bit by recursing once. However,
+      -- this way is likely less surprising.
+      [ ANN desc (MOV ip (OpImm (ImmInt n))),
+        ADD sp sp ip
+      ]
+  where
+    desc = text "Move SP:" <+> int n
+
+--
+-- See Note [extra spill slots] in X86/Instr.hs
+--
+allocMoreStack ::
+  Platform ->
+  Int ->
+  NatCmmDecl statics GHC.CmmToAsm.RV64.Instr.Instr ->
+  UniqSM (NatCmmDecl statics GHC.CmmToAsm.RV64.Instr.Instr, [(BlockId, BlockId)])
+allocMoreStack _ _ top@(CmmData _ _) = return (top, [])
+allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do
+  let entries = entryBlocks proc
+
+  uniqs <- getUniquesM
+
+  let delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up
+        where
+          x = slots * spillSlotSize -- sp delta
+      alloc = mkStackAllocInstr platform delta
+      dealloc = mkStackDeallocInstr platform delta
+
+      retargetList = zip entries (map mkBlockId uniqs)
+
+      new_blockmap :: LabelMap BlockId
+      new_blockmap = mapFromList retargetList
+
+      insert_stack_insn (BasicBlock id insns)
+        | Just new_blockid <- mapLookup id new_blockmap =
+            [ BasicBlock id $ alloc ++ [B (TBlock new_blockid)],
+              BasicBlock new_blockid block'
+            ]
+        | otherwise =
+            [BasicBlock id block']
+        where
+          block' = foldr insert_dealloc [] insns
+
+      insert_dealloc insn r = case insn of
+        J_TBL {} -> dealloc ++ (insn : r)
+        ANN _ e -> insert_dealloc e r
+        _other
+          | jumpDestsOfInstr insn /= [] ->
+              patchJumpInstr insn retarget : r
+        _other -> insn : r
+        where
+          retarget b = fromMaybe b (mapLookup b new_blockmap)
+
+      new_code = concatMap insert_stack_insn code
+  return (CmmProc info lbl live (ListGraph new_code), retargetList)
+
+data Instr
+  = -- | Comment pseudo-op
+    COMMENT SDoc
+  | -- | Multi-line comment pseudo-op
+    MULTILINE_COMMENT SDoc
+  | -- | Annotated instruction. Should print <instr> # <doc>
+    ANN SDoc Instr
+  | -- | Location pseudo-op @.loc@ (file, line, col, name)
+    LOCATION Int Int Int LexicalFastString
+  | -- | Static data spat out during code generation.
+    LDATA Section RawCmmStatics
+  | -- | Start a new basic block.
+    --
+    -- Useful during codegen, removed later. Preceding instruction should be a
+    -- jump, as per the invariants for a BasicBlock (see Cmm).
+    NEWBLOCK BlockId
+  | -- | Specify current stack offset for benefit of subsequent passes
+    DELTA Int
+  | -- | Push a minimal stack frame consisting of the return address (RA) and the frame pointer (FP).
+    PUSH_STACK_FRAME
+  | -- | Pop the minimal stack frame of prior `PUSH_STACK_FRAME`.
+    POP_STACK_FRAME
+  | -- | Arithmetic addition (both integer and floating point)
+    --
+    -- @rd = rs1 + rs2@
+    ADD Operand Operand Operand
+  | -- | Arithmetic subtraction (both integer and floating point)
+    --
+    -- @rd = rs1 - rs2@
+    SUB Operand Operand Operand
+  | -- | Logical AND (integer only)
+    --
+    -- @rd = rs1 & rs2@
+    AND Operand Operand Operand
+  | -- | Logical OR (integer only)
+    --
+    -- @rd = rs1 | rs2@
+    OR Operand Operand Operand
+  | -- | Logical left shift (zero extened, integer only)
+    --
+    -- @rd = rs1 << rs2@
+    SLL Operand Operand Operand
+  | -- | Logical right shift (zero extened, integer only)
+    --
+    -- @rd = rs1 >> rs2@
+    SRL Operand Operand Operand
+  | -- | Arithmetic right shift (sign-extened, integer only)
+    --
+    -- @rd = rs1 >> rs2@
+    SRA Operand Operand Operand
+  | -- | Store to memory (both, integer and floating point)
+    STR Format Operand Operand
+  | -- | Load from memory (sign-extended, integer and floating point)
+    LDR Format Operand Operand
+  | -- | Load from memory (unsigned, integer and floating point)
+    LDRU Format Operand Operand
+  | -- | Arithmetic multiplication (both, integer and floating point)
+    --
+    -- @rd = rn × rm@
+    MUL Operand Operand Operand
+  | -- | Negation (both, integer and floating point)
+    --
+    -- @rd = -op2@
+    NEG Operand Operand
+  | -- | Division (both, integer and floating point)
+    --
+    -- @rd = rn ÷ rm@
+    DIV Operand Operand Operand
+  | -- | Remainder (integer only, signed)
+    --
+    -- @rd = rn % rm@
+    REM Operand Operand Operand --
+  | -- | Remainder (integer only, unsigned)
+    --
+    -- @rd = |rn % rm|@
+    REMU Operand Operand Operand
+  | -- | High part of a multiplication that doesn't fit into 64bits (integer only)
+    --
+    -- E.g. for a multiplication with 64bits width: @rd = (rs1 * rs2) >> 64@.
+    MULH Operand Operand Operand
+  | -- | Unsigned division (integer only)
+    --
+    -- @rd = |rn ÷ rm|@
+    DIVU Operand Operand Operand
+  | -- | XOR (integer only)
+    --
+    -- @rd = rn ⊕ op2@
+    XOR Operand Operand Operand
+  | -- | ORI with immediate (integer only)
+    --
+    -- @rd = rn | op2@
+    ORI Operand Operand Operand
+  | -- | OR with immediate (integer only)
+    --
+    -- @rd = rn ⊕ op2@
+    XORI Operand Operand Operand
+  | -- | Move to register (integer and floating point)
+    --
+    -- @rd = rn@  or  @rd = #imm@
+    MOV Operand Operand
+  | -- | Pseudo-op for conditional setting of a register.
+    --
+    -- @if(o2 cond o3) op <- 1 else op <- 0@
+    CSET Operand Operand Operand Cond
+  | -- | A jump instruction with data for switch/jump tables
+    J_TBL [Maybe BlockId] (Maybe CLabel) Reg
+  | -- | Unconditional jump (no linking)
+    B Target
+  | -- | Unconditional jump, links return address (sets @ra@/@x1@)
+    BL Reg [Reg]
+  | -- | branch with condition (integer only)
+    BCOND Cond Operand Operand Target
+  | -- | Fence instruction
+    --
+    -- Memory barrier.
+    FENCE FenceType FenceType
+  | -- | Floating point conversion
+    FCVT FcvtVariant Operand Operand
+  | -- | Floating point ABSolute value
+    FABS Operand Operand
+  | -- | Floating-point fused multiply-add instructions
+    --
+    -- - fmadd : d =   r1 * r2 + r3
+    -- - fnmsub: d =   r1 * r2 - r3
+    -- - fmsub : d = - r1 * r2 + r3
+    -- - fnmadd: d = - r1 * r2 - r3
+    FMA FMASign Operand Operand Operand Operand
+
+-- | Operand of a FENCE instruction (@r@, @w@ or @rw@)
+data FenceType = FenceRead | FenceWrite | FenceReadWrite
+
+-- | Variant of a floating point conversion instruction
+data FcvtVariant = FloatToFloat | IntToFloat | FloatToInt
+
+instrCon :: Instr -> String
+instrCon i =
+  case i of
+    COMMENT {} -> "COMMENT"
+    MULTILINE_COMMENT {} -> "COMMENT"
+    ANN {} -> "ANN"
+    LOCATION {} -> "LOCATION"
+    LDATA {} -> "LDATA"
+    NEWBLOCK {} -> "NEWBLOCK"
+    DELTA {} -> "DELTA"
+    PUSH_STACK_FRAME {} -> "PUSH_STACK_FRAME"
+    POP_STACK_FRAME {} -> "POP_STACK_FRAME"
+    ADD {} -> "ADD"
+    OR {} -> "OR"
+    MUL {} -> "MUL"
+    NEG {} -> "NEG"
+    DIV {} -> "DIV"
+    REM {} -> "REM"
+    REMU {} -> "REMU"
+    MULH {} -> "MULH"
+    SUB {} -> "SUB"
+    DIVU {} -> "DIVU"
+    AND {} -> "AND"
+    SRA {} -> "SRA"
+    XOR {} -> "XOR"
+    SLL {} -> "SLL"
+    SRL {} -> "SRL"
+    MOV {} -> "MOV"
+    ORI {} -> "ORI"
+    XORI {} -> "ORI"
+    STR {} -> "STR"
+    LDR {} -> "LDR"
+    LDRU {} -> "LDRU"
+    CSET {} -> "CSET"
+    J_TBL {} -> "J_TBL"
+    B {} -> "B"
+    BL {} -> "BL"
+    BCOND {} -> "BCOND"
+    FENCE {} -> "FENCE"
+    FCVT {} -> "FCVT"
+    FABS {} -> "FABS"
+    FMA variant _ _ _ _ ->
+      case variant of
+        FMAdd -> "FMADD"
+        FMSub -> "FMSUB"
+        FNMAdd -> "FNMADD"
+        FNMSub -> "FNMSUB"
+
+data Target
+  = TBlock BlockId
+  | TReg Reg
+
+data Operand
+  = -- | register
+    OpReg Width Reg
+  | -- | immediate value
+    OpImm Imm
+  | -- | memory reference
+    OpAddr AddrMode
+  deriving (Eq, Show)
+
+operandFromReg :: Reg -> Operand
+operandFromReg = OpReg W64
+
+operandFromRegNo :: RegNo -> Operand
+operandFromRegNo = operandFromReg . regSingle
+
+zero, ra, sp, gp, tp, fp, ip :: Operand
+zero = operandFromReg zeroReg
+ra = operandFromReg raReg
+sp = operandFromReg spMachReg
+gp = operandFromRegNo 3
+tp = operandFromRegNo 4
+fp = operandFromRegNo 8
+ip = operandFromReg ipReg
+
+x0, x1, x2, x3, x4, x5, x6, x7 :: Operand
+x8, x9, x10, x11, x12, x13, x14, x15 :: Operand
+x16, x17, x18, x19, x20, x21, x22, x23 :: Operand
+x24, x25, x26, x27, x28, x29, x30, x31 :: Operand
+x0 = operandFromRegNo x0RegNo
+x1 = operandFromRegNo 1
+x2 = operandFromRegNo 2
+x3 = operandFromRegNo 3
+x4 = operandFromRegNo 4
+x5 = operandFromRegNo x5RegNo
+x6 = operandFromRegNo 6
+x7 = operandFromRegNo x7RegNo
+
+x8 = operandFromRegNo 8
+
+x9 = operandFromRegNo 9
+
+x10 = operandFromRegNo x10RegNo
+
+x11 = operandFromRegNo 11
+
+x12 = operandFromRegNo 12
+
+x13 = operandFromRegNo 13
+
+x14 = operandFromRegNo 14
+
+x15 = operandFromRegNo 15
+
+x16 = operandFromRegNo 16
+
+x17 = operandFromRegNo x17RegNo
+
+x18 = operandFromRegNo 18
+
+x19 = operandFromRegNo 19
+
+x20 = operandFromRegNo 20
+
+x21 = operandFromRegNo 21
+
+x22 = operandFromRegNo 22
+
+x23 = operandFromRegNo 23
+
+x24 = operandFromRegNo 24
+
+x25 = operandFromRegNo 25
+
+x26 = operandFromRegNo 26
+
+x27 = operandFromRegNo 27
+
+x28 = operandFromRegNo x28RegNo
+
+x29 = operandFromRegNo 29
+
+x30 = operandFromRegNo 30
+
+x31 = operandFromRegNo x31RegNo
+
+d0, d1, d2, d3, d4, d5, d6, d7 :: Operand
+d8, d9, d10, d11, d12, d13, d14, d15 :: Operand
+d16, d17, d18, d19, d20, d21, d22, d23 :: Operand
+d24, d25, d26, d27, d28, d29, d30, d31 :: Operand
+d0 = operandFromRegNo d0RegNo
+d1 = operandFromRegNo 33
+d2 = operandFromRegNo 34
+d3 = operandFromRegNo 35
+d4 = operandFromRegNo 36
+d5 = operandFromRegNo 37
+d6 = operandFromRegNo 38
+d7 = operandFromRegNo d7RegNo
+
+d8 = operandFromRegNo 40
+
+d9 = operandFromRegNo 41
+
+d10 = operandFromRegNo d10RegNo
+
+d11 = operandFromRegNo 43
+
+d12 = operandFromRegNo 44
+
+d13 = operandFromRegNo 45
+
+d14 = operandFromRegNo 46
+
+d15 = operandFromRegNo 47
+
+d16 = operandFromRegNo 48
+
+d17 = operandFromRegNo d17RegNo
+
+d18 = operandFromRegNo 50
+
+d19 = operandFromRegNo 51
+
+d20 = operandFromRegNo 52
+
+d21 = operandFromRegNo 53
+
+d22 = operandFromRegNo 54
+
+d23 = operandFromRegNo 55
+
+d24 = operandFromRegNo 56
+
+d25 = operandFromRegNo 57
+
+d26 = operandFromRegNo 58
+
+d27 = operandFromRegNo 59
+
+d28 = operandFromRegNo 60
+
+d29 = operandFromRegNo 61
+
+d30 = operandFromRegNo 62
+
+d31 = operandFromRegNo d31RegNo
+
+fitsIn12bitImm :: (Num a, Ord a) => a -> Bool
+fitsIn12bitImm off = off >= intMin12bit && off <= intMax12bit
+
+intMin12bit :: (Num a) => a
+intMin12bit = -2048
+
+intMax12bit :: (Num a) => a
+intMax12bit = 2047
+
+fitsIn32bits :: (Num a, Ord a, Bits a) => a -> Bool
+fitsIn32bits i = (-1 `shiftL` 31) <= i && i <= (1 `shiftL` 31 - 1)
+
+isNbitEncodeable :: Int -> Integer -> Bool
+isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)
+
+isEncodeableInWidth :: Width -> Integer -> Bool
+isEncodeableInWidth = isNbitEncodeable . widthInBits
+
+isIntOp :: Operand -> Bool
+isIntOp = not . isFloatOp
+
+isFloatOp :: Operand -> Bool
+isFloatOp (OpReg _ reg) | isFloatReg reg = True
+isFloatOp _ = False
+
+isFloatReg :: Reg -> Bool
+isFloatReg (RegReal (RealRegSingle i)) | i > 31 = True
+isFloatReg (RegVirtual (VirtualRegF _)) = True
+isFloatReg (RegVirtual (VirtualRegD _)) = True
+isFloatReg _ = False

compiler/GHC/CmmToAsm/RV64/Ppr.hs

+{-# LANGUAGE ScopedTypeVariables #-}
+
+module GHC.CmmToAsm.RV64.Ppr (pprNatCmmDecl, pprInstr) where
+
+import GHC.Cmm hiding (topInfoTable)
+import GHC.Cmm.BlockId
+import GHC.Cmm.CLabel
+import GHC.Cmm.Dataflow.Label
+import GHC.CmmToAsm.Config
+import GHC.CmmToAsm.Format
+import GHC.CmmToAsm.Ppr
+import GHC.CmmToAsm.RV64.Cond
+import GHC.CmmToAsm.RV64.Instr
+import GHC.CmmToAsm.RV64.Regs
+import GHC.CmmToAsm.Types
+import GHC.CmmToAsm.Utils
+import GHC.Platform
+import GHC.Platform.Reg
+import GHC.Prelude hiding (EQ)
+import GHC.Types.Basic (Alignment, alignmentBytes, mkAlignment)
+import GHC.Types.Unique (getUnique, pprUniqueAlways)
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+
+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
+
+      pprProcAlignment :: doc
+      pprProcAlignment = maybe empty (pprAlign . mkAlignment) (ncgProcAlignment config)
+   in pprProcAlignment
+        $$ case topInfoTable proc of
+          Nothing ->
+            -- special case for code without info table:
+            pprSectionAlign config (Section Text lbl)
+              $$
+              -- do not
+              -- pprProcAlignment config $$
+              pprLabel platform lbl
+              $$ vcat (map (pprBasicBlock config top_info) blocks) -- blocks guaranteed not null, so label needed
+              $$ ppWhen
+                (ncgDwarfEnabled config)
+                (line (pprBlockEndLabel platform lbl) $$ line (pprProcEndLabel platform lbl))
+              $$ pprSizeDecl platform lbl
+          Just (CmmStaticsRaw info_lbl _) ->
+            pprSectionAlign config (Section Text info_lbl)
+              $$
+              -- pprProcAlignment config $$
+              ( if platformHasSubsectionsViaSymbols platform
+                  then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':')
+                  else empty
+              )
+              $$ vcat (map (pprBasicBlock config top_info) blocks)
+              $$ ppWhen (ncgDwarfEnabled config) (line (pprProcEndLabel platform info_lbl))
+              $$
+              -- above: Even the first block gets a label, because with branch-chain
+              -- elimination, it might be the target of a goto.
+              ( if platformHasSubsectionsViaSymbols platform
+                  then -- See Note [Subsections Via Symbols]
+
+                    line
+                      $ text "\t.long "
+                      <+> pprAsmLabel platform info_lbl
+                      <+> char '-'
+                      <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl)
+                  else empty
+              )
+              $$ pprSizeDecl platform info_lbl
+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc #-}
+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
+
+pprLabel :: (IsDoc doc) => Platform -> CLabel -> doc
+pprLabel platform lbl =
+  pprGloblDecl platform lbl
+    $$ pprTypeDecl platform lbl
+    $$ line (pprAsmLabel platform lbl <> char ':')
+
+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)
+
+-- | Print appropriate alignment for the given section type.
+--
+-- 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 will e.g. emit a header like:
+--
+--     .section .text
+--     .balign 8
+pprSectionAlign :: (IsDoc doc) => NCGConfig -> Section -> doc
+pprSectionAlign _config (Section (OtherSection _) _) =
+  panic "RV64.Ppr.pprSectionAlign: unknown section"
+pprSectionAlign config sec@(Section seg _) =
+  line (pprSectionHeader config sec)
+    $$ pprAlignForSection seg
+
+pprProcEndLabel ::
+  (IsLine doc) =>
+  Platform ->
+  -- | Procedure name
+  CLabel ->
+  doc
+pprProcEndLabel platform lbl =
+  pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon
+
+pprBlockEndLabel ::
+  (IsLine doc) =>
+  Platform ->
+  -- | Block name
+  CLabel ->
+  doc
+pprBlockEndLabel platform lbl =
+  pprAsmLabel platform (mkAsmTempEndLabel lbl) <> colon
+
+-- | Output the ELF .size directive (if needed.)
+pprSizeDecl :: (IsDoc doc) => Platform -> CLabel -> doc
+pprSizeDecl platform lbl
+  | 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 ->
+  doc
+pprBasicBlock config info_env (BasicBlock blockid instrs) =
+  maybe_infotable
+    $ pprLabel platform asmLbl
+    $$ vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs))
+    $$ ppWhen
+      (ncgDwarfEnabled config)
+      ( -- Emit both end labels since this may end up being a standalone
+        -- top-level block
+        line
+          ( pprBlockEndLabel platform asmLbl
+              <> pprProcEndLabel platform asmLbl
+          )
+      )
+  where
+    -- TODO: Check if we can  filter more instructions here.
+    -- TODO: Shouldn't this be a more general check on a higher level?
+    -- Filter out identity moves. E.g. mov x18, x18 will be dropped.
+    optInstrs = filter f instrs
+      where
+        f (MOV o1 o2) | o1 == o2 = False
+        f _ = True
+
+    asmLbl = blockLbl blockid
+    platform = ncgPlatform config
+    maybe_infotable c = case mapLookup blockid info_env of
+      Nothing -> c
+      Just (CmmStaticsRaw info_lbl info) ->
+        --  pprAlignForSection platform Text $$
+        infoTableLoc
+          $$ vcat (map (pprData config) info)
+          $$ pprLabel platform info_lbl
+          $$ c
+          $$ ppWhen
+            (ncgDwarfEnabled config)
+            (line (pprBlockEndLabel platform info_lbl))
+    -- Make sure the info table has the right .loc for the block
+    -- coming right after it. See Note [Info Offset]
+    infoTableLoc = case instrs of
+      (l@LOCATION {} : _) -> pprInstr platform l
+      _other -> empty
+
+pprDatas :: (IsDoc doc) => NCGConfig -> RawCmmStatics -> doc
+-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
+pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
+  | lbl == mkIndStaticInfoLabel,
+    let labelInd (CmmLabelOff l _) = Just l
+        labelInd (CmmLabel l) = Just l
+        labelInd _ = Nothing,
+    Just ind' <- labelInd ind,
+    alias `mayRedirectTo` ind' =
+      pprGloblDecl (ncgPlatform config) alias
+        $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind')
+pprDatas config (CmmStaticsRaw lbl dats) =
+  vcat (pprLabel platform lbl : map (pprData config) dats)
+  where
+    platform = ncgPlatform config
+
+pprData :: (IsDoc doc) => NCGConfig -> CmmStatic -> doc
+pprData _config (CmmString str) = line (pprString str)
+pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path)
+-- TODO: AFAIK there no Darwin for RISCV, so we may consider to simplify this.
+pprData config (CmmUninitialised bytes) =
+  line
+    $ let platform = ncgPlatform config
+       in if platformOS platform == OSDarwin
+            then text ".space " <> int bytes
+            else text ".skip " <> int bytes
+pprData config (CmmStaticLit lit) = pprDataItem config lit
+
+pprGloblDecl :: (IsDoc doc) => Platform -> CLabel -> doc
+pprGloblDecl platform lbl
+  | not (externallyVisibleCLabel lbl) = empty
+  | otherwise = line (text "\t.globl " <> pprAsmLabel platform lbl)
+
+-- Note [Always use objects for info tables]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- See discussion in X86.Ppr for why this is necessary.  Essentially we need to
+-- ensure that we never pass function symbols when we might want to lookup the
+-- info table.  If we did, we could end up with procedure linking tables
+-- (PLT)s, and thus the lookup wouldn't point to the function, but into the
+-- jump table.
+--
+-- Fun fact: The LLVMMangler exists to patch this issue su on the LLVM side as
+-- well.
+pprLabelType' :: (IsLine doc) => Platform -> CLabel -> doc
+pprLabelType' platform lbl =
+  if isCFunctionLabel lbl || functionOkInfoTable
+    then text "@function"
+    else text "@object"
+  where
+    functionOkInfoTable =
+      platformTablesNextToCode platform
+        && isInfoTableLabel lbl
+        && not (isCmmInfoTableLabel lbl)
+        && not (isConInfoTableLabel lbl)
+
+-- this is called pprTypeAndSizeDecl in PPC.Ppr
+pprTypeDecl :: (IsDoc doc) => Platform -> CLabel -> doc
+pprTypeDecl platform lbl =
+  if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl
+    then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl)
+    else empty
+
+pprDataItem :: (IsDoc doc) => NCGConfig -> CmmLit -> doc
+pprDataItem config lit =
+  lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)
+  where
+    platform = ncgPlatform config
+
+    imm = litToImm lit
+
+    ppr_item II8 _ = [text "\t.byte\t" <> pprDataImm platform imm]
+    ppr_item II16 _ = [text "\t.short\t" <> pprDataImm platform imm]
+    ppr_item II32 _ = [text "\t.long\t" <> pprDataImm platform imm]
+    ppr_item II64 _ = [text "\t.quad\t" <> pprDataImm platform imm]
+    ppr_item FF32 (CmmFloat r _) =
+      let bs = floatToBytes (fromRational r)
+       in map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs
+    ppr_item FF64 (CmmFloat r _) =
+      let bs = doubleToBytes (fromRational r)
+       in map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs
+    ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit)
+
+-- | Pretty print an immediate value in the @data@ section
+--
+-- This does not include any checks. We rely on the Assembler to check for
+-- errors. Use `pprOpImm` for immediates in instructions (operands.)
+pprDataImm :: (IsLine doc) => Platform -> Imm -> doc
+pprDataImm _ (ImmInt i) = int i
+pprDataImm _ (ImmInteger i) = integer i
+pprDataImm p (ImmCLbl l) = pprAsmLabel p l
+pprDataImm p (ImmIndex l i) = pprAsmLabel p l <> char '+' <> int i
+pprDataImm _ (ImmLit s) = ftext s
+pprDataImm _ (ImmFloat f) = float (fromRational f)
+pprDataImm _ (ImmDouble d) = double (fromRational d)
+pprDataImm p (ImmConstantSum a b) = pprDataImm p a <> char '+' <> pprDataImm p b
+pprDataImm p (ImmConstantDiff a b) =
+  pprDataImm p a
+    <> char '-'
+    <> lparen
+    <> pprDataImm p b
+    <> rparen
+
+-- | Comment @c@ with @# c@
+asmComment :: SDoc -> SDoc
+asmComment c = text "#" <+> c
+
+-- | Commen @c@ with @// c@
+asmDoubleslashComment :: SDoc -> SDoc
+asmDoubleslashComment c = text "//" <+> c
+
+-- | Comment @c@ with @/* c */@ (multiline comment)
+asmMultilineComment :: SDoc -> SDoc
+asmMultilineComment c = text "/*" $+$ c $+$ text "*/"
+
+-- | Pretty print an immediate operand of an instruction
+--
+-- The kinds of immediates we can use here is pretty limited: RISCV doesn't
+-- support index expressions (as e.g. Aarch64 does.) Floating points need to
+-- fit in range. As we don't need them, forbit them to save us from future
+-- troubles.
+pprOpImm :: (IsLine doc) => Platform -> Imm -> doc
+pprOpImm platform im = case im of
+  ImmInt i -> int i
+  ImmInteger i -> integer i
+  ImmCLbl l -> char '=' <> pprAsmLabel platform l
+  _ -> pprPanic "RV64.Ppr.pprOpImm" (text "Unsupported immediate for instruction operands" <> colon <+> (text . show) im)
+
+-- | Negate integer immediate operand
+--
+-- This function is partial and will panic if the operand is not an integer.
+negOp :: Operand -> Operand
+negOp (OpImm (ImmInt i)) = OpImm (ImmInt (negate i))
+negOp (OpImm (ImmInteger i)) = OpImm (ImmInteger (negate i))
+negOp op = pprPanic "RV64.negOp" (text $ show op)
+
+-- | Pretty print an operand
+pprOp :: (IsLine doc) => Platform -> Operand -> doc
+pprOp plat op = case op of
+  OpReg w r -> pprReg w r
+  OpImm im -> pprOpImm plat im
+  OpAddr (AddrRegImm r1 im) -> pprOpImm plat im <> char '(' <> pprReg W64 r1 <> char ')'
+  OpAddr (AddrReg r1) -> text "0(" <+> pprReg W64 r1 <+> char ')'
+
+-- | Pretty print register with calling convention name
+--
+-- This representation makes it easier to reason about the emitted assembly
+-- code.
+pprReg :: forall doc. (IsLine doc) => Width -> Reg -> doc
+pprReg w r = case r of
+  RegReal (RealRegSingle i) -> ppr_reg_no i
+  -- virtual regs should not show up, but this is helpful for debugging.
+  RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u
+  RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u
+  RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u
+  _ -> pprPanic "RiscV64.pprReg" (text (show r) <+> ppr w)
+  where
+    ppr_reg_no :: Int -> doc
+    -- General Purpose Registers
+    ppr_reg_no 0 = text "zero"
+    ppr_reg_no 1 = text "ra"
+    ppr_reg_no 2 = text "sp"
+    ppr_reg_no 3 = text "gp"
+    ppr_reg_no 4 = text "tp"
+    ppr_reg_no 5 = text "t0"
+    ppr_reg_no 6 = text "t1"
+    ppr_reg_no 7 = text "t2"
+    ppr_reg_no 8 = text "s0"
+    ppr_reg_no 9 = text "s1"
+    ppr_reg_no 10 = text "a0"
+    ppr_reg_no 11 = text "a1"
+    ppr_reg_no 12 = text "a2"
+    ppr_reg_no 13 = text "a3"
+    ppr_reg_no 14 = text "a4"
+    ppr_reg_no 15 = text "a5"
+    ppr_reg_no 16 = text "a6"
+    ppr_reg_no 17 = text "a7"
+    ppr_reg_no 18 = text "s2"
+    ppr_reg_no 19 = text "s3"
+    ppr_reg_no 20 = text "s4"
+    ppr_reg_no 21 = text "s5"
+    ppr_reg_no 22 = text "s6"
+    ppr_reg_no 23 = text "s7"
+    ppr_reg_no 24 = text "s8"
+    ppr_reg_no 25 = text "s9"
+    ppr_reg_no 26 = text "s10"
+    ppr_reg_no 27 = text "s11"
+    ppr_reg_no 28 = text "t3"
+    ppr_reg_no 29 = text "t4"
+    ppr_reg_no 30 = text "t5"
+    ppr_reg_no 31 = text "t6"
+    -- Floating Point Registers
+    ppr_reg_no 32 = text "ft0"
+    ppr_reg_no 33 = text "ft1"
+    ppr_reg_no 34 = text "ft2"
+    ppr_reg_no 35 = text "ft3"
+    ppr_reg_no 36 = text "ft4"
+    ppr_reg_no 37 = text "ft5"
+    ppr_reg_no 38 = text "ft6"
+    ppr_reg_no 39 = text "ft7"
+    ppr_reg_no 40 = text "fs0"
+    ppr_reg_no 41 = text "fs1"
+    ppr_reg_no 42 = text "fa0"
+    ppr_reg_no 43 = text "fa1"
+    ppr_reg_no 44 = text "fa2"
+    ppr_reg_no 45 = text "fa3"
+    ppr_reg_no 46 = text "fa4"
+    ppr_reg_no 47 = text "fa5"
+    ppr_reg_no 48 = text "fa6"
+    ppr_reg_no 49 = text "fa7"
+    ppr_reg_no 50 = text "fs2"
+    ppr_reg_no 51 = text "fs3"
+    ppr_reg_no 52 = text "fs4"
+    ppr_reg_no 53 = text "fs5"
+    ppr_reg_no 54 = text "fs6"
+    ppr_reg_no 55 = text "fs7"
+    ppr_reg_no 56 = text "fs8"
+    ppr_reg_no 57 = text "fs9"
+    ppr_reg_no 58 = text "fs10"
+    ppr_reg_no 59 = text "fs11"
+    ppr_reg_no 60 = text "ft8"
+    ppr_reg_no 61 = text "ft9"
+    ppr_reg_no 62 = text "ft10"
+    ppr_reg_no 63 = text "ft11"
+    ppr_reg_no i
+      | i < 0 = pprPanic "Unexpected register number (min is 0)" (ppr w <+> int i)
+      | i > 63 = pprPanic "Unexpected register number (max is 63)" (ppr w <+> int i)
+      -- 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
+
+-- | Get the pretty-printed label from a `Target`
+--
+-- This function is partial and will panic if the `Target` is not a label.
+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"
+
+-- | Pretty-print an `Instr`
+--
+-- This function is partial and will panic if the `Instr` is not supported. This
+-- can happen due to invalid operands or unexpected meta instructions.
+pprInstr :: (IsDoc doc) => Platform -> Instr -> doc
+pprInstr platform instr = case instr of
+  -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable
+  COMMENT s -> dualDoc (asmComment s) empty
+  MULTILINE_COMMENT s -> dualDoc (asmMultilineComment s) empty
+  ANN d i -> dualDoc (pprInstr platform i <+> asmDoubleslashComment d) (pprInstr platform i)
+  LOCATION file line' col _name ->
+    line (text "\t.loc" <+> int file <+> int line' <+> int col)
+  DELTA d -> dualDoc (asmComment $ text "\tdelta = " <> int d) empty
+  NEWBLOCK _ -> panic "PprInstr: NEWBLOCK"
+  LDATA _ _ -> panic "pprInstr: LDATA"
+  PUSH_STACK_FRAME ->
+    lines_
+      [ text "\taddi sp, sp, -16",
+        text "\tsd x1, 8(sp)", -- store RA
+        text "\tsd x8, 0(sp)", -- store FP/s0
+        text "\taddi x8, sp, 16"
+      ]
+  POP_STACK_FRAME ->
+    lines_
+      [ text "\tld x8, 0(sp)", -- restore FP/s0
+        text "\tld x1, 8(sp)", -- restore RA
+        text "\taddi sp, sp, 16"
+      ]
+  ADD o1 o2 o3
+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfadd." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3
+    -- This case is used for sign extension: SEXT.W op
+    | OpReg W64 _ <- o1, OpReg W32 _ <- o2, isImmOp o3 -> op3 (text "\taddiw") o1 o2 o3
+    | otherwise -> op3 (text "\tadd") o1 o2 o3
+  MUL o1 o2 o3
+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfmul." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3
+    | otherwise -> op3 (text "\tmul") o1 o2 o3
+  MULH o1 o2 o3 -> op3 (text "\tmulh") o1 o2 o3
+  NEG o1 o2 | isFloatOp o1 && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfneg.s") o1 o2
+  NEG o1 o2 | isFloatOp o1 && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfneg.d") o1 o2
+  NEG o1 o2 -> op2 (text "\tneg") o1 o2
+  DIV o1 o2 o3
+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 ->
+        -- TODO: This must (likely) be refined regarding width
+        op3 (text "\tfdiv." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3
+  DIV o1 o2 o3 -> op3 (text "\tdiv") o1 o2 o3
+  REM o1 o2 o3
+    | isFloatOp o1 || isFloatOp o2 || isFloatOp o3 ->
+        panic "pprInstr - REM not implemented for floats (yet)"
+  REM o1 o2 o3 -> op3 (text "\trem") o1 o2 o3
+  REMU o1 o2 o3 -> op3 (text "\tremu") o1 o2 o3
+  SUB o1 o2 o3
+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfsub." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3
+    | isImmOp o3 -> op3 (text "\taddi") o1 o2 (negOp o3)
+    | otherwise -> op3 (text "\tsub") o1 o2 o3
+  DIVU o1 o2 o3 -> op3 (text "\tdivu") o1 o2 o3
+  AND o1 o2 o3
+    | isImmOp o3 -> op3 (text "\tandi") o1 o2 o3
+    | otherwise -> op3 (text "\tand") o1 o2 o3
+  OR o1 o2 o3 -> op3 (text "\tor") o1 o2 o3
+  SRA o1 o2 o3 | isImmOp o3 -> op3 (text "\tsrai") o1 o2 o3
+  SRA o1 o2 o3 -> op3 (text "\tsra") o1 o2 o3
+  XOR o1 o2 o3 -> op3 (text "\txor") o1 o2 o3
+  SLL o1 o2 o3 -> op3 (text "\tsll") o1 o2 o3
+  SRL o1 o2 o3 -> op3 (text "\tsrl") o1 o2 o3
+  MOV o1 o2
+    | isFloatOp o1 && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfmv.d") o1 o2 -- fmv.d rd, rs is pseudo op fsgnj.d rd, rs, rs
+    | isFloatOp o1 && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfmv.s") o1 o2 -- fmv.s rd, rs is pseudo op fsgnj.s rd, rs, rs
+    | isFloatOp o1 && isImmZero o2 && isDoubleOp o1 -> op2 (text "\tfcvt.d.w") o1 zero
+    | isFloatOp o1 && isImmZero o2 && isSingleOp o1 -> op2 (text "\tfcvt.s.w") o1 zero
+    | isFloatOp o1 && not (isFloatOp o2) && isSingleOp o1 -> op2 (text "\tfmv.w.x") o1 o2
+    | isFloatOp o1 && not (isFloatOp o2) && isDoubleOp o1 -> op2 (text "\tfmv.d.x") o1 o2
+    | not (isFloatOp o1) && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfmv.x.w") o1 o2
+    | not (isFloatOp o1) && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfmv.x.d") o1 o2
+    | (OpImm (ImmInteger i)) <- o2,
+      fitsIn12bitImm i ->
+        lines_ [text "\taddi" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <> comma <+> pprOp platform o2]
+    | (OpImm (ImmInt i)) <- o2,
+      fitsIn12bitImm i ->
+        lines_ [text "\taddi" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <> comma <+> pprOp platform o2]
+    | (OpImm (ImmInteger i)) <- o2,
+      fitsIn32bits i ->
+        lines_
+          [ text "\tlui" <+> pprOp platform o1 <> comma <+> text "%hi(" <> pprOp platform o2 <> text ")",
+            text "\taddw" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%lo(" <> pprOp platform o2 <> text ")"
+          ]
+    | (OpImm (ImmInt i)) <- o2,
+      fitsIn32bits i ->
+        lines_
+          [ text "\tlui" <+> pprOp platform o1 <> comma <+> text "%hi(" <> pprOp platform o2 <> text ")",
+            text "\taddw" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%lo(" <> pprOp platform o2 <> text ")"
+          ]
+    | isImmOp o2 ->
+        -- Surrender! Let the assembler figure out the right expressions with pseudo-op LI.
+        lines_ [text "\tli" <+> pprOp platform o1 <> comma <+> pprOp platform o2]
+    | otherwise -> op3 (text "\taddi") o1 o2 (OpImm (ImmInt 0))
+  ORI o1 o2 o3 -> op3 (text "\tori") o1 o2 o3
+  XORI o1 o2 o3 -> op3 (text "\txori") o1 o2 o3
+  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" <+> pprOp platform x0 <> 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
+  BCOND _ _ _ (TReg _) -> panic "RV64.ppr: No conditional branching to registers!"
+  CSET o l r c -> case c of
+    EQ
+      | isIntOp l && isIntOp r ->
+          lines_
+            [ subFor l r,
+              text "\tseqz" <+> pprOp platform o <> comma <+> pprOp platform o
+            ]
+    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
+            ]
+    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]
+    SLE ->
+      lines_
+        [ sltFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l,
+          text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"
+        ]
+    SGE ->
+      lines_
+        [ sltFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r,
+          text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"
+        ]
+    SGT -> lines_ [sltFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l]
+    ULT -> lines_ [sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r]
+    ULE ->
+      lines_
+        [ sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l,
+          text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"
+        ]
+    UGE ->
+      lines_
+        [ sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r,
+          text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"
+        ]
+    UGT -> lines_ [sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l]
+    FLT | isFloatOp l && isFloatOp r -> line $ binOp ("\tflt." ++ floatOpPrecision platform l r)
+    FLE | isFloatOp l && isFloatOp r -> line $ binOp ("\tfle." ++ floatOpPrecision platform l r)
+    FGT | isFloatOp l && isFloatOp r -> line $ binOp ("\tfgt." ++ floatOpPrecision platform l r)
+    FGE | isFloatOp l && isFloatOp r -> line $ binOp ("\tfge." ++ floatOpPrecision platform l r)
+    x -> pprPanic "RV64.ppr: unhandled CSET conditional" (text (show x) <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l)
+    where
+      subFor l r
+        | (OpImm _) <- r = text "\taddi" <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform (negOp r)
+        | (OpImm _) <- l = panic "RV64.ppr: Cannot SUB IMM _"
+        | otherwise = text "\tsub" <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r
+      sltFor l r
+        | (OpImm _) <- r = text "\tslti"
+        | (OpImm _) <- l = panic "PV64.ppr: Cannot SLT IMM _"
+        | otherwise = text "\tslt"
+      sltuFor l r
+        | (OpImm _) <- r = text "\tsltui"
+        | (OpImm _) <- l = panic "PV64.ppr: Cannot SLTU IMM _"
+        | otherwise = text "\tsltu"
+      binOp :: (IsLine doc) => String -> doc
+      binOp op = text op <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r
+  STR II8 o1 o2 -> op2 (text "\tsb") o1 o2
+  STR II16 o1 o2 -> op2 (text "\tsh") o1 o2
+  STR II32 o1 o2 -> op2 (text "\tsw") o1 o2
+  STR II64 o1 o2 -> op2 (text "\tsd") o1 o2
+  STR FF32 o1 o2 -> op2 (text "\tfsw") o1 o2
+  STR FF64 o1 o2 -> op2 (text "\tfsd") o1 o2
+  LDR _f o1 (OpImm (ImmIndex lbl off)) ->
+    lines_
+      [ text "\tla" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl,
+        text "\taddi" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off
+      ]
+  LDR _f o1 (OpImm (ImmCLbl lbl)) ->
+    line $ text "\tla" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl
+  LDR II8 o1 o2 -> op2 (text "\tlb") o1 o2
+  LDR II16 o1 o2 -> op2 (text "\tlh") o1 o2
+  LDR II32 o1 o2 -> op2 (text "\tlw") o1 o2
+  LDR II64 o1 o2 -> op2 (text "\tld") o1 o2
+  LDR FF32 o1 o2 -> op2 (text "\tflw") o1 o2
+  LDR FF64 o1 o2 -> op2 (text "\tfld") o1 o2
+  LDRU II8 o1 o2 -> op2 (text "\tlbu") o1 o2
+  LDRU II16 o1 o2 -> op2 (text "\tlhu") o1 o2
+  LDRU II32 o1 o2 -> op2 (text "\tlwu") o1 o2
+  -- double words (64bit) cannot be sign extended by definition
+  LDRU II64 o1 o2 -> op2 (text "\tld") o1 o2
+  LDRU FF32 o1 o2@(OpAddr (AddrReg _)) -> op2 (text "\tflw") o1 o2
+  LDRU FF32 o1 o2@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tflw") o1 o2
+  LDRU FF64 o1 o2@(OpAddr (AddrReg _)) -> op2 (text "\tfld") o1 o2
+  LDRU FF64 o1 o2@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tfld") o1 o2
+  LDRU f o1 o2 -> pprPanic "Unsupported unsigned load" ((text . show) f <+> pprOp platform o1 <+> pprOp platform o2)
+  FENCE r w -> line $ text "\tfence" <+> pprFenceType r <> char ',' <+> pprFenceType w
+  FCVT FloatToFloat o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.d") o1 o2
+  FCVT FloatToFloat o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.s") o1 o2
+  FCVT FloatToFloat o1 o2 ->
+    pprPanic "RV64.pprInstr - impossible float to float conversion"
+      $ line (pprOp platform o1 <> text "->" <> pprOp platform o2)
+  FCVT IntToFloat o1@(OpReg W32 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.s.w") o1 o2
+  FCVT IntToFloat o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.l") o1 o2
+  FCVT IntToFloat o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.w") o1 o2
+  FCVT IntToFloat o1@(OpReg W64 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.d.l") o1 o2
+  FCVT IntToFloat o1 o2 ->
+    pprPanic "RV64.pprInstr - impossible integer to float conversion"
+      $ line (pprOp platform o1 <> text "->" <> pprOp platform o2)
+  FCVT FloatToInt o1@(OpReg W32 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.w.s") o1 o2
+  FCVT FloatToInt o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.w.d") o1 o2
+  FCVT FloatToInt o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.l.s") o1 o2
+  FCVT FloatToInt o1@(OpReg W64 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.l.d") o1 o2
+  FCVT FloatToInt o1 o2 ->
+    pprPanic "RV64.pprInstr - impossible float to integer conversion"
+      $ line (pprOp platform o1 <> text "->" <> pprOp platform o2)
+  FABS o1 o2 | isSingleOp o2 -> op2 (text "\tfabs.s") o1 o2
+  FABS o1 o2 | isDoubleOp o2 -> op2 (text "\tfabs.d") o1 o2
+  FMA variant d r1 r2 r3 ->
+    let fma = case variant of
+          FMAdd -> text "\tfmadd" <> dot <> floatPrecission d
+          FMSub -> text "\tfmsub" <> dot <> floatPrecission d
+          FNMAdd -> text "\tfnmadd" <> dot <> floatPrecission d
+          FNMSub -> text "\tfnmsub" <> dot <> floatPrecission d
+     in op4 fma d r1 r2 r3
+  instr -> panic $ "RV64.pprInstr - Unknown instruction: " ++ instrCon instr
+  where
+    op2 op o1 o2 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2
+    op3 op o1 o2 o3 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3
+    op4 op o1 o2 o3 o4 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4
+    pprFenceType FenceRead = text "r"
+    pprFenceType FenceWrite = text "w"
+    pprFenceType FenceReadWrite = text "rw"
+    floatPrecission o
+      | isSingleOp o = text "s"
+      | isDoubleOp o = text "d"
+      | otherwise = pprPanic "Impossible floating point precission: " (pprOp platform o)
+
+floatOpPrecision :: Platform -> Operand -> Operand -> String
+floatOpPrecision _p l r | isFloatOp l && isFloatOp r && isSingleOp l && isSingleOp r = "s" -- single precision
+floatOpPrecision _p l r | isFloatOp l && isFloatOp r && isDoubleOp l && isDoubleOp r = "d" -- double precision
+floatOpPrecision p l r = pprPanic "Cannot determine floating point precission" (text "op1" <+> pprOp p l <+> text "op2" <+> pprOp p r)
+
+-- | Pretty print a conditional branch
+--
+-- This function is partial and will panic if the conditional is not supported;
+-- i.e. if its floating point related.
+pprBcond :: (IsLine doc) => Cond -> doc
+pprBcond c = text "b" <> pprCond c
+  where
+    pprCond :: (IsLine doc) => Cond -> doc
+    pprCond c = case c of
+      EQ -> text "eq"
+      NE -> text "ne"
+      SLT -> text "lt"
+      SLE -> text "le"
+      SGE -> text "ge"
+      SGT -> text "gt"
+      ULT -> text "ltu"
+      ULE -> text "leu"
+      UGE -> text "geu"
+      UGT -> text "gtu"
+      -- BCOND cannot handle floating point comparisons / registers
+      _ -> panic $ "RV64.ppr: unhandled BCOND conditional: " ++ show c

compiler/GHC/CmmToAsm/RV64/RegInfo.hs

+-- | Minimum viable implementation of jump short-cutting: No short-cutting.
+--
+-- The functions here simply implement the no-short-cutting case. Implementing
+-- the real behaviour would be a great optimization in future.
+module GHC.CmmToAsm.RV64.RegInfo
+  ( getJumpDestBlockId,
+    canShortcut,
+    shortcutStatics,
+    shortcutJump,
+    JumpDest (..),
+  )
+where
+
+import GHC.Cmm
+import GHC.Cmm.BlockId
+import GHC.CmmToAsm.RV64.Instr
+import GHC.Prelude
+import GHC.Utils.Outputable
+
+newtype JumpDest = DestBlockId BlockId
+
+instance Outputable JumpDest where
+  ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid
+
+-- | Extract BlockId
+--
+-- Never `Nothing` for Riscv64 NCG.
+getJumpDestBlockId :: JumpDest -> Maybe BlockId
+getJumpDestBlockId (DestBlockId bid) = Just bid
+
+-- No `Instr`s can bet shortcut (for now)
+canShortcut :: Instr -> Maybe JumpDest
+canShortcut _ = Nothing
+
+-- Identity of the provided `RawCmmStatics`
+shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics
+shortcutStatics _ other_static = other_static
+
+-- Identity of the provided `Instr`
+shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
+shortcutJump _ other = other