pool/ghc
SHA256
4
0
Fork 1
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
ghc/riscv64-ncg.patch

6218 lines
234 KiB
Diff
Raw Permalink Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

Index: ghc-9.10.1/CODEOWNERS
===================================================================
--- ghc-9.10.1.orig/CODEOWNERS
+++ ghc-9.10.1/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
Index: ghc-9.10.1/compiler/CodeGen.Platform.h
===================================================================
--- ghc-9.10.1.orig/compiler/CodeGen.Platform.h
+++ ghc-9.10.1/compiler/CodeGen.Platform.h
@@ -1,7 +1,8 @@
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
@@ -1041,6 +1042,105 @@ freeReg 18 = 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
+
+#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 TMP (IP) register]
+freeReg 31 = False
+
+# if defined(REG_Base)
+freeReg REG_Base = False
# endif
# if defined(REG_Sp)
freeReg REG_Sp = False
Index: ghc-9.10.1/compiler/GHC/Cmm/CLabel.hs
===================================================================
--- ghc-9.10.1.orig/compiler/GHC/Cmm/CLabel.hs
+++ ghc-9.10.1/compiler/GHC/Cmm/CLabel.hs
@@ -1720,6 +1720,8 @@ pprDynamicLinkerAsmLabel !platform dllIn
| platformArch platform == ArchAArch64
= ppLbl
+ | platformArch platform == ArchRISCV64
+ = ppLbl
| platformArch platform == ArchX86_64
= case dllInfo of
Index: ghc-9.10.1/compiler/GHC/CmmToAsm.hs
===================================================================
--- ghc-9.10.1.orig/compiler/GHC/CmmToAsm.hs
+++ ghc-9.10.1/compiler/GHC/CmmToAsm.hs
@@ -67,6 +67,7 @@ import qualified GHC.CmmToAsm.X86 as X
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
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"
Index: ghc-9.10.1/compiler/GHC/CmmToAsm/Dwarf/Constants.hs
===================================================================
--- ghc-9.10.1.orig/compiler/GHC/CmmToAsm/Dwarf/Constants.hs
+++ ghc-9.10.1/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!"
Index: ghc-9.10.1/compiler/GHC/CmmToAsm/PIC.hs
===================================================================
--- ghc-9.10.1.orig/compiler/GHC/CmmToAsm/PIC.hs
+++ ghc-9.10.1/compiler/GHC/CmmToAsm/PIC.hs
@@ -132,6 +132,11 @@ cmmMakeDynamicReference config reference
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))
Index: ghc-9.10.1/compiler/GHC/CmmToAsm/RV64.hs
===================================================================
--- /dev/null
+++ ghc-9.10.1/compiler/GHC/CmmToAsm/RV64.hs
@@ -0,0 +1,57 @@
+{-# 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
+ 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
Index: ghc-9.10.1/compiler/GHC/CmmToAsm/RV64/CodeGen.hs
===================================================================
--- /dev/null
+++ ghc-9.10.1/compiler/GHC/CmmToAsm/RV64/CodeGen.hs
@@ -0,0 +1,2207 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module GHC.CmmToAsm.RV64.CodeGen
+ ( cmmTopCodeGen,
+ generateJumpTableForInstr,
+ makeFarBranches,
+ )
+where
+
+import Control.Monad
+import Data.Maybe
+import Data.Word
+import GHC.Cmm
+import GHC.Cmm.BlockId
+import GHC.Cmm.CLabel
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Graph
+import GHC.Cmm.Dataflow.Label
+import GHC.Cmm.DebugBlock
+import GHC.Cmm.Switch
+import GHC.Cmm.Utils
+import GHC.CmmToAsm.CPrim
+import GHC.CmmToAsm.Config
+import GHC.CmmToAsm.Format
+import GHC.CmmToAsm.Monad
+ ( NatM,
+ getBlockIdNat,
+ getConfig,
+ getDebugBlock,
+ getFileId,
+ getNewLabelNat,
+ getNewRegNat,
+ getPicBaseMaybeNat,
+ getPlatform,
+ )
+import GHC.CmmToAsm.PIC
+import GHC.CmmToAsm.RV64.Cond
+import GHC.CmmToAsm.RV64.Instr
+import GHC.CmmToAsm.RV64.Regs
+import GHC.CmmToAsm.Types
+import GHC.Data.FastString
+import GHC.Data.OrdList
+import GHC.Float
+import GHC.Platform
+import GHC.Platform.Reg
+import GHC.Platform.Regs
+import GHC.Prelude hiding (EQ)
+import GHC.Types.Basic
+import GHC.Types.ForeignCall
+import GHC.Types.SrcLoc (srcSpanFile, srcSpanStartCol, srcSpanStartLine)
+import GHC.Types.Tickish (GenTickish (..))
+import GHC.Types.Unique.Supply
+import GHC.Utils.Constants (debugIsOn)
+import GHC.Utils.Misc
+import GHC.Utils.Monad
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+
+-- For an overview of an NCG's structure, see Note [General layout of an NCG]
+
+cmmTopCodeGen ::
+ RawCmmDecl ->
+ NatM [NatCmmDecl RawCmmStatics Instr]
+-- Thus we'll have to deal with either CmmProc ...
+cmmTopCodeGen _cmm@(CmmProc info lab live graph) = do
+ picBaseMb <- getPicBaseMaybeNat
+ when (isJust picBaseMb) $ panic "RV64.cmmTopCodeGen: Unexpected PIC base register (RISCV ISA does not define one)"
+
+ let blocks = toBlockListEntryFirst graph
+ (nat_blocks, statics) <- mapAndUnzipM basicBlockCodeGen blocks
+
+ let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)
+ tops = proc : concat statics
+
+ pure tops
+
+-- ... or CmmData.
+cmmTopCodeGen (CmmData sec dat) = pure [CmmData sec dat] -- no translation, we just use CmmStatic
+
+basicBlockCodeGen ::
+ Block CmmNode C C ->
+ NatM
+ ( [NatBasicBlock Instr],
+ [NatCmmDecl RawCmmStatics Instr]
+ )
+basicBlockCodeGen block = do
+ config <- getConfig
+ let (_, nodes, tail) = blockSplit block
+ id = entryLabel block
+ stmts = blockToList nodes
+
+ header_comment_instr
+ | debugIsOn =
+ unitOL
+ $ MULTILINE_COMMENT
+ ( text "-- --------------------------- basicBlockCodeGen --------------------------- --\n"
+ $+$ withPprStyle defaultDumpStyle (pdoc (ncgPlatform config) block)
+ )
+ | otherwise = nilOL
+
+ -- Generate location directive `.loc` (DWARF debug location info)
+ loc_instrs <- genLocInstrs
+
+ -- Generate other instructions
+ mid_instrs <- stmtsToInstrs stmts
+ (!tail_instrs) <- stmtToInstrs tail
+
+ let instrs = header_comment_instr `appOL` loc_instrs `appOL` mid_instrs `appOL` tail_instrs
+
+ -- TODO: Then x86 backend runs @verifyBasicBlock@ here. How important it is to
+ -- have a valid CFG is an open question: This and the AArch64 and PPC NCGs
+ -- work fine without it.
+
+ -- Code generation may introduce new basic block boundaries, which are
+ -- indicated by the NEWBLOCK instruction. We must split up the instruction
+ -- stream into basic blocks again. Also, we extract LDATAs here too.
+ (top, other_blocks, statics) = foldrOL mkBlocks ([], [], []) instrs
+
+ return (BasicBlock id top : other_blocks, statics)
+ where
+ genLocInstrs :: NatM (OrdList Instr)
+ genLocInstrs = do
+ dbg <- getDebugBlock (entryLabel block)
+ case dblSourceTick =<< dbg of
+ Just (SourceNote span name) ->
+ do
+ fileId <- getFileId (srcSpanFile span)
+ let line = srcSpanStartLine span; col = srcSpanStartCol span
+ pure $ unitOL $ LOCATION fileId line col name
+ _ -> pure nilOL
+
+mkBlocks ::
+ Instr ->
+ ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g]) ->
+ ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
+mkBlocks (NEWBLOCK id) (instrs, blocks, statics) =
+ ([], BasicBlock id instrs : blocks, statics)
+mkBlocks (LDATA sec dat) (instrs, blocks, statics) =
+ (instrs, blocks, CmmData sec dat : statics)
+mkBlocks instr (instrs, blocks, statics) =
+ (instr : instrs, blocks, statics)
+
+-- -----------------------------------------------------------------------------
+
+-- | Utilities
+
+-- | Annotate an `Instr` with a `SDoc` comment
+ann :: SDoc -> Instr -> Instr
+ann doc instr {- debugIsOn -} = ANN doc instr
+{-# INLINE ann #-}
+
+-- Using pprExpr will hide the AST, @ANN@ will end up in the assembly with
+-- -dppr-debug. The idea is that we can trivially see how a cmm expression
+-- ended up producing the assembly we see. By having the verbatim AST printed
+-- we can simply check the patterns that were matched to arrive at the assembly
+-- we generated.
+--
+-- pprExpr will hide a lot of noise of the underlying data structure and print
+-- the expression into something that can be easily read by a human. However
+-- going back to the exact CmmExpr representation can be laborious and adds
+-- indirections to find the matches that lead to the assembly.
+--
+-- An improvement could be to have
+--
+-- (pprExpr genericPlatform e) <> parens (text. show e)
+--
+-- to have the best of both worlds.
+--
+-- Note: debugIsOn is too restrictive, it only works for debug compilers.
+-- However, we do not only want to inspect this for debug compilers. Ideally
+-- we'd have a check for -dppr-debug here already, such that we don't even
+-- generate the ANN expressions. However, as they are lazy, they shouldn't be
+-- forced until we actually force them, and without -dppr-debug they should
+-- never end up being forced.
+annExpr :: CmmExpr -> Instr -> Instr
+annExpr e {- debugIsOn -} = ANN (text . show $ e)
+-- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr
+-- annExpr _ instr = instr
+{-# INLINE annExpr #-}
+
+-- -----------------------------------------------------------------------------
+-- Generating a table-branch
+
+-- Note [RISCV64 Jump Tables]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Jump tables are implemented by generating a table of relative addresses,
+-- where each entry is the relative offset to the target block from the first
+-- entry / table label (`generateJumpTableForInstr`). Using the jump table means
+-- loading the entry's value and jumping to the calculated absolute address
+-- (`genSwitch`).
+--
+-- For example, this Cmm switch
+--
+-- switch [1 .. 10] _s2wn::I64 {
+-- case 1 : goto c347;
+-- case 2 : goto c348;
+-- case 3 : goto c349;
+-- case 4 : goto c34a;
+-- case 5 : goto c34b;
+-- case 6 : goto c34c;
+-- case 7 : goto c34d;
+-- case 8 : goto c34e;
+-- case 9 : goto c34f;
+-- case 10 : goto c34g;
+-- } // CmmSwitch
+--
+-- leads to this jump table in Assembly
+--
+-- .section .rodata
+-- .balign 8
+-- .Ln34G:
+-- .quad 0
+-- .quad .Lc347-(.Ln34G)+0
+-- .quad .Lc348-(.Ln34G)+0
+-- .quad .Lc349-(.Ln34G)+0
+-- .quad .Lc34a-(.Ln34G)+0
+-- .quad .Lc34b-(.Ln34G)+0
+-- .quad .Lc34c-(.Ln34G)+0
+-- .quad .Lc34d-(.Ln34G)+0
+-- .quad .Lc34e-(.Ln34G)+0
+-- .quad .Lc34f-(.Ln34G)+0
+-- .quad .Lc34g-(.Ln34G)+0
+--
+-- and this indexing code where the jump should be done (register t0 contains
+-- the index)
+--
+-- addi t0, t0, 0 // silly move (ignore it)
+-- la t1, .Ln34G // load the table's address
+-- sll t0, t0, 3 // index * 8 -> offset in bytes
+-- add t0, t0, t1 // address of the table's entry
+-- ld t0, 0(t0) // load entry
+-- add t0, t0, t1 // relative to absolute address
+-- jalr zero, t0, 0 // jump to the block
+--
+-- In object code (disassembled) the table looks like
+--
+-- 0000000000000000 <.Ln34G>:
+-- ...
+-- 8: R_RISCV_ADD64 .Lc347
+-- 8: R_RISCV_SUB64 .Ln34G
+-- 10: R_RISCV_ADD64 .Lc348
+-- 10: R_RISCV_SUB64 .Ln34G
+-- 18: R_RISCV_ADD64 .Lc349
+-- 18: R_RISCV_SUB64 .Ln34G
+-- 20: R_RISCV_ADD64 .Lc34a
+-- 20: R_RISCV_SUB64 .Ln34G
+-- 28: R_RISCV_ADD64 .Lc34b
+-- 28: R_RISCV_SUB64 .Ln34G
+-- 30: R_RISCV_ADD64 .Lc34c
+-- 30: R_RISCV_SUB64 .Ln34G
+-- 38: R_RISCV_ADD64 .Lc34d
+-- 38: R_RISCV_SUB64 .Ln34G
+-- 40: R_RISCV_ADD64 .Lc34e
+-- 40: R_RISCV_SUB64 .Ln34G
+-- 48: R_RISCV_ADD64 .Lc34f
+-- 48: R_RISCV_SUB64 .Ln34G
+-- 50: R_RISCV_ADD64 .Lc34g
+-- 50: R_RISCV_SUB64 .Ln34G
+--
+-- I.e. the relative offset calculations are done by the linker via relocations.
+-- This seems to be PIC compatible; at least `scanelf` (pax-utils) does not
+-- complain.
+
+
+-- | Generate jump to jump table target
+--
+-- The index into the jump table is calulated by evaluating @expr@. The
+-- corresponding table entry contains the relative address to jump to (relative
+-- to the jump table's first entry / the table's own label).
+genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock
+genSwitch config expr targets = do
+ (reg, fmt1, e_code) <- getSomeReg indexExpr
+ let fmt = II64
+ targetReg <- getNewRegNat fmt
+ lbl <- getNewLabelNat
+ dynRef <- cmmMakeDynamicReference config DataReference lbl
+ (tableReg, fmt2, t_code) <- getSomeReg dynRef
+ let code =
+ toOL
+ [ COMMENT (text "indexExpr" <+> (text . show) indexExpr),
+ COMMENT (text "dynRef" <+> (text . show) dynRef)
+ ]
+ `appOL` e_code
+ `appOL` t_code
+ `appOL` toOL
+ [ COMMENT (ftext "Jump table for switch"),
+ -- index to offset into the table (relative to tableReg)
+ annExpr expr (SLL (OpReg (formatToWidth fmt1) reg) (OpReg (formatToWidth fmt1) reg) (OpImm (ImmInt 3))),
+ -- calculate table entry address
+ ADD (OpReg W64 targetReg) (OpReg (formatToWidth fmt1) reg) (OpReg (formatToWidth fmt2) tableReg),
+ -- load table entry (relative offset from tableReg (first entry) to target label)
+ LDRU II64 (OpReg W64 targetReg) (OpAddr (AddrRegImm targetReg (ImmInt 0))),
+ -- calculate absolute address of the target label
+ ADD (OpReg W64 targetReg) (OpReg W64 targetReg) (OpReg W64 tableReg),
+ -- prepare jump to target label
+ J_TBL ids (Just lbl) targetReg
+ ]
+ return code
+ where
+ -- See Note [Sub-word subtlety during jump-table indexing] in
+ -- GHC.CmmToAsm.X86.CodeGen for why we must first offset, then widen.
+ indexExpr0 = cmmOffset platform expr offset
+ -- We widen to a native-width register to sanitize the high bits
+ indexExpr =
+ CmmMachOp
+ (MO_UU_Conv expr_w (platformWordWidth platform))
+ [indexExpr0]
+ expr_w = cmmExprWidth platform expr
+ (offset, ids) = switchTargetsToTable targets
+ platform = ncgPlatform config
+
+-- | Generate jump table data (if required)
+--
+-- The idea is to emit one table entry per case. The entry is the relative
+-- address of the block to jump to (relative to the table's first entry /
+-- table's own label.) The calculation itself is done by the linker.
+generateJumpTableForInstr ::
+ NCGConfig ->
+ Instr ->
+ Maybe (NatCmmDecl RawCmmStatics Instr)
+generateJumpTableForInstr config (J_TBL ids (Just lbl) _) =
+ let jumpTable =
+ map jumpTableEntryRel ids
+ where
+ jumpTableEntryRel Nothing =
+ CmmStaticLit (CmmInt 0 (ncgWordWidth config))
+ jumpTableEntryRel (Just blockid) =
+ CmmStaticLit
+ ( CmmLabelDiffOff
+ blockLabel
+ lbl
+ 0
+ (ncgWordWidth config)
+ )
+ where
+ blockLabel = blockLbl blockid
+ in Just (CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl jumpTable))
+generateJumpTableForInstr _ _ = Nothing
+
+-- -----------------------------------------------------------------------------
+-- Top-level of the instruction selector
+
+stmtsToInstrs ::
+ -- | Cmm Statements
+ [CmmNode O O] ->
+ -- | Resulting instruction
+ NatM InstrBlock
+stmtsToInstrs stmts = concatOL <$> mapM stmtToInstrs stmts
+
+stmtToInstrs ::
+ CmmNode e x ->
+ -- | Resulting instructions
+ NatM InstrBlock
+stmtToInstrs stmt = do
+ config <- getConfig
+ platform <- getPlatform
+ case stmt of
+ CmmUnsafeForeignCall target result_regs args ->
+ genCCall target result_regs args
+ CmmComment s -> pure (unitOL (COMMENT (ftext s)))
+ CmmTick {} -> pure nilOL
+ CmmAssign reg src
+ | isFloatType ty -> assignReg_FltCode format reg src
+ | otherwise -> assignReg_IntCode format reg src
+ where
+ ty = cmmRegType reg
+ format = cmmTypeFormat ty
+ CmmStore addr src _alignment
+ | isFloatType ty -> assignMem_FltCode format addr src
+ | otherwise -> assignMem_IntCode format addr src
+ where
+ ty = cmmExprType platform src
+ format = cmmTypeFormat ty
+ CmmBranch id -> genBranch id
+ -- We try to arrange blocks such that the likely branch is the fallthrough
+ -- in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.
+ CmmCondBranch arg true false _prediction ->
+ genCondBranch true false arg
+ CmmSwitch arg ids -> genSwitch config arg ids
+ CmmCall {cml_target = arg} -> genJump arg
+ CmmUnwind _regs -> pure nilOL
+ -- Intentionally not have a default case here: If anybody adds a
+ -- constructor, the compiler should force them to think about this here.
+ CmmForeignCall {} -> pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt)
+ CmmEntry {} -> pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt)
+
+--------------------------------------------------------------------------------
+
+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.
+--
+-- They are really trees of insns to facilitate fast appending, where a
+-- left-to-right traversal yields the insns in the correct order.
+type InstrBlock =
+ OrdList Instr
+
+-- | Register's passed up the tree.
+--
+-- If the stix code forces the register to live in a pre-decided machine
+-- register, it comes out as @Fixed@; otherwise, it comes out as @Any@, and the
+-- parent can decide which register to put it in.
+data Register
+ = Fixed Format Reg InstrBlock
+ | Any Format (Reg -> InstrBlock)
+
+-- | Sometimes we need to change the Format of a register. Primarily during
+-- conversion.
+swizzleRegisterRep :: Format -> Register -> Register
+swizzleRegisterRep format' (Fixed _format reg code) = Fixed format' reg code
+swizzleRegisterRep format' (Any _format codefn) = Any format' codefn
+
+-- | Grab a `Reg` for a `CmmReg`
+--
+-- `LocalReg`s are assigned virtual registers (`RegVirtual`), `GlobalReg`s are
+-- assigned real registers (`RegReal`). It is an error if a `GlobalReg` is not a
+-- STG register.
+getRegisterReg :: Platform -> CmmReg -> Reg
+getRegisterReg _ (CmmLocal (LocalReg u pk)) =
+ RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)
+getRegisterReg platform (CmmGlobal mid) =
+ case globalRegMaybe platform (globalRegUseGlobalReg mid) of
+ Just reg -> RegReal reg
+ Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
+
+-- -----------------------------------------------------------------------------
+-- General things for putting together code sequences
+
+-- | Compute an expression into any register
+getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock)
+getSomeReg expr = do
+ r <- getRegister expr
+ case r of
+ Any rep code -> do
+ newReg <- getNewRegNat rep
+ return (newReg, rep, code newReg)
+ Fixed rep reg code ->
+ return (reg, rep, code)
+
+-- | Compute an expression into any floating-point register
+--
+-- If the initial expression is not a floating-point expression, finally move
+-- the result into a floating-point register.
+getFloatReg :: (HasCallStack) => CmmExpr -> NatM (Reg, Format, InstrBlock)
+getFloatReg expr = do
+ r <- getRegister expr
+ case r of
+ Any rep code | isFloatFormat rep -> do
+ newReg <- getNewRegNat rep
+ return (newReg, rep, code newReg)
+ Any II32 code -> do
+ newReg <- getNewRegNat FF32
+ return (newReg, FF32, code newReg)
+ Any II64 code -> do
+ newReg <- getNewRegNat FF64
+ return (newReg, FF64, code newReg)
+ Any _w _code -> do
+ config <- getConfig
+ pprPanic "can't do getFloatReg on" (pdoc (ncgPlatform config) expr)
+ -- can't do much for fixed.
+ Fixed rep reg code ->
+ return (reg, rep, code)
+
+-- | Map `CmmLit` to `OpImm`
+--
+-- N.B. this is a partial function, because not all `CmmLit`s have an immediate
+-- representation.
+litToImm' :: CmmLit -> Operand
+litToImm' = OpImm . litToImm
+
+-- | Compute a `CmmExpr` into a `Register`
+getRegister :: CmmExpr -> NatM Register
+getRegister e = do
+ config <- getConfig
+ getRegister' config (ncgPlatform config) e
+
+-- | The register width to be used for an operation on the given width
+-- operand.
+opRegWidth :: Width -> Width
+opRegWidth W64 = W64
+opRegWidth W32 = W32
+opRegWidth W16 = W32
+opRegWidth W8 = W32
+opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w)
+
+-- Note [Signed arithmetic on RISCV64]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Handling signed arithmetic on sub-word-size values on RISCV64 is a bit
+-- tricky as Cmm's type system does not capture signedness. While 32-bit values
+-- are fairly easy to handle due to RISCV64's 32-bit instruction variants
+-- (denoted by use of %wN registers), 16- and 8-bit values require quite some
+-- care.
+--
+-- We handle 16-and 8-bit values by using the 32-bit operations and
+-- sign-/zero-extending operands and truncate results as necessary. For
+-- simplicity we maintain the invariant that a register containing a
+-- sub-word-size value always contains the zero-extended form of that value
+-- in between operations.
+--
+-- For instance, consider the program,
+--
+-- test(bits64 buffer)
+-- bits8 a = bits8[buffer];
+-- bits8 b = %mul(a, 42);
+-- bits8 c = %not(b);
+-- bits8 d = %shrl(c, 4::bits8);
+-- return (d);
+-- }
+--
+-- This program begins by loading `a` from memory, for which we use a
+-- zero-extended byte-size load. We next sign-extend `a` to 32-bits, and use a
+-- 32-bit multiplication to compute `b`, and truncate the result back down to
+-- 8-bits.
+--
+-- Next we compute `c`: The `%not` requires no extension of its operands, but
+-- we must still truncate the result back down to 8-bits. Finally the `%shrl`
+-- requires no extension and no truncate since we can assume that
+-- `c` is zero-extended.
+--
+-- The "RISC-V Sign Extension Optimizations" LLVM tech talk presentation by
+-- Craig Topper covers possible future improvements
+-- (https://llvm.org/devmtg/2022-11/slides/TechTalk21-RISC-VSignExtensionOptimizations.pdf)
+--
+--
+-- Note [Handling PIC on RV64]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- RV64 does not have a special PIC register, the general approach is to simply
+-- do PC-relative addressing or go through the GOT. There is assembly support
+-- for both.
+--
+-- rv64 assembly has a `la` (load address) pseudo-instruction, that allows
+-- loading a label's address into a register. The instruction is desugared into
+-- different addressing modes, e.g. PC-relative addressing:
+--
+-- 1: lui rd1, %pcrel_hi(label)
+-- addi rd1, %pcrel_lo(1b)
+--
+-- See https://sourceware.org/binutils/docs/as/RISC_002dV_002dModifiers.html,
+-- PIC can be enabled/disabled through
+--
+-- .option pic
+--
+-- See https://sourceware.org/binutils/docs/as/RISC_002dV_002dDirectives.html#RISC_002dV_002dDirectives
+--
+-- CmmGlobal @PicBaseReg@'s are generated in @GHC.CmmToAsm.PIC@ in the
+-- @cmmMakePicReference@. This is in turn called from @cmmMakeDynamicReference@
+-- also in @Cmm.CmmToAsm.PIC@ from where it is also exported. There are two
+-- callsites for this. One is in this module to produce the @target@ in @genCCall@
+-- the other is in @GHC.CmmToAsm@ in @cmmExprNative@.
+--
+-- Conceptually we do not want any special PicBaseReg to be used on RV64. If
+-- we want to distinguish between symbol loading, we need to address this through
+-- the way we load it, not through a register.
+--
+
+getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register
+-- OPTIMIZATION WARNING: CmmExpr rewrites
+-- 1. Rewrite: Reg + (-n) => Reg - n
+-- TODO: this expression shouldn't even be generated to begin with.
+getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt i w1)])
+ | i < 0 =
+ getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt (-i) w1)])
+getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt i w1)])
+ | i < 0 =
+ getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt (-i) w1)])
+-- Generic case.
+getRegister' config plat expr =
+ case expr of
+ CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)) ->
+ -- See Note [Handling PIC on RV64]
+ pprPanic "getRegister': There's no PIC base register on RISCV" (ppr PicBaseReg)
+ CmmLit lit ->
+ case lit of
+ CmmInt 0 w -> pure $ Fixed (intFormat w) zeroReg nilOL
+ CmmInt i w ->
+ -- narrowU is important: Negative immediates may be
+ -- sign-extended on load!
+ let imm = OpImm . ImmInteger $ narrowU w i
+ in pure (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg w dst) imm)))
+ CmmFloat 0 w -> do
+ let op = litToImm' lit
+ pure (Any (floatFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg w dst) op)))
+ CmmFloat _f W8 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for bytes" (pdoc plat expr)
+ CmmFloat _f W16 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for halfs" (pdoc plat expr)
+ CmmFloat f W32 -> do
+ let word = castFloatToWord32 (fromRational f) :: Word32
+ intReg <- getNewRegNat (intFormat W32)
+ return
+ ( Any
+ (floatFormat W32)
+ ( \dst ->
+ toOL
+ [ annExpr expr
+ $ MOV (OpReg W32 intReg) (OpImm (ImmInteger (fromIntegral word))),
+ MOV (OpReg W32 dst) (OpReg W32 intReg)
+ ]
+ )
+ )
+ CmmFloat f W64 -> do
+ let word = castDoubleToWord64 (fromRational f) :: Word64
+ intReg <- getNewRegNat (intFormat W64)
+ return
+ ( Any
+ (floatFormat W64)
+ ( \dst ->
+ toOL
+ [ annExpr expr
+ $ MOV (OpReg W64 intReg) (OpImm (ImmInteger (fromIntegral word))),
+ MOV (OpReg W64 dst) (OpReg W64 intReg)
+ ]
+ )
+ )
+ CmmFloat _f _w -> pprPanic "getRegister' (CmmLit:CmmFloat), unsupported float lit" (pdoc plat expr)
+ CmmVec _lits -> pprPanic "getRegister' (CmmLit:CmmVec): " (pdoc plat expr)
+ CmmLabel lbl -> do
+ let op = OpImm (ImmCLbl lbl)
+ rep = cmmLitType plat lit
+ format = cmmTypeFormat rep
+ return (Any format (\dst -> unitOL $ annExpr expr (LDR format (OpReg (formatToWidth format) dst) op)))
+ CmmLabelOff lbl off | isNbitEncodeable 12 (fromIntegral off) -> do
+ let op = OpImm (ImmIndex lbl off)
+ rep = cmmLitType plat lit
+ format = cmmTypeFormat rep
+ return (Any format (\dst -> unitOL $ LDR format (OpReg (formatToWidth format) dst) op))
+ CmmLabelOff lbl off -> do
+ let op = litToImm' (CmmLabel lbl)
+ rep = cmmLitType plat lit
+ format = cmmTypeFormat rep
+ width = typeWidth rep
+ (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width)
+ return
+ ( Any
+ format
+ ( \dst ->
+ off_code
+ `snocOL` LDR format (OpReg (formatToWidth format) dst) op
+ `snocOL` ADD (OpReg width dst) (OpReg width dst) (OpReg width off_r)
+ )
+ )
+ CmmLabelDiffOff {} -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)
+ CmmBlock _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)
+ CmmHighStackMark -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)
+ CmmLoad mem rep _ -> do
+ let format = cmmTypeFormat rep
+ width = typeWidth rep
+ Amode addr addr_code <- getAmode plat width mem
+ case width of
+ w
+ | w <= W64 ->
+ -- Load without sign-extension. See Note [Signed arithmetic on RISCV64]
+ pure
+ ( Any
+ format
+ ( \dst ->
+ addr_code
+ `snocOL` LDRU format (OpReg width dst) (OpAddr addr)
+ )
+ )
+ _ ->
+ pprPanic ("Width too big! Cannot load: " ++ show width) (pdoc plat expr)
+ CmmStackSlot _ _ ->
+ pprPanic "getRegister' (CmmStackSlot): " (pdoc plat expr)
+ CmmReg reg ->
+ return
+ ( Fixed
+ (cmmTypeFormat (cmmRegType reg))
+ (getRegisterReg plat reg)
+ nilOL
+ )
+ CmmRegOff reg off | isNbitEncodeable 12 (fromIntegral off) -> do
+ getRegister' config plat
+ $ CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
+ where
+ width = typeWidth (cmmRegType reg)
+ CmmRegOff reg off -> do
+ (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width)
+ (reg, _format, code) <- getSomeReg $ CmmReg reg
+ return
+ $ Any
+ (intFormat width)
+ ( \dst ->
+ off_code
+ `appOL` code
+ `snocOL` ADD (OpReg width dst) (OpReg width reg) (OpReg width off_r)
+ )
+ where
+ width = typeWidth (cmmRegType reg)
+
+ -- Handle MO_RelaxedRead as a normal CmmLoad, to allow
+ -- non-trivial addressing modes to be used.
+ CmmMachOp (MO_RelaxedRead w) [e] ->
+ getRegister (CmmLoad e (cmmBits w) NaturallyAligned)
+ -- for MachOps, see GHC.Cmm.MachOp
+ -- For CmmMachOp, see GHC.Cmm.Expr
+ CmmMachOp op [e] -> do
+ (reg, _format, code) <- getSomeReg e
+ case op of
+ MO_Not w -> return $ Any (intFormat w) $ \dst ->
+ let w' = opRegWidth w
+ in code
+ `snocOL`
+ -- pseudo instruction `not` is `xori rd, rs, -1`
+ ann (text "not") (XORI (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt (-1))))
+ `appOL` truncateReg w' w dst -- See Note [Signed arithmetic on RISCV64]
+ MO_S_Neg w -> negate code w reg
+ MO_F_Neg w ->
+ return
+ $ Any
+ (floatFormat w)
+ ( \dst ->
+ code
+ `snocOL` NEG (OpReg w dst) (OpReg w reg)
+ )
+ -- TODO: Can this case happen?
+ MO_SF_Conv from to | from < W32 -> do
+ -- extend to the smallest available representation
+ (reg_x, code_x) <- signExtendReg from W32 reg
+ pure
+ $ Any
+ (floatFormat to)
+ ( \dst ->
+ code
+ `appOL` code_x
+ `snocOL` annExpr expr (FCVT IntToFloat (OpReg to dst) (OpReg from reg_x)) -- (Signed ConVerT Float)
+ )
+ MO_SF_Conv from to ->
+ pure
+ $ Any
+ (floatFormat to)
+ ( \dst ->
+ code
+ `snocOL` annExpr expr (FCVT IntToFloat (OpReg to dst) (OpReg from reg)) -- (Signed ConVerT Float)
+ )
+ MO_FS_Conv from to
+ | to < W32 ->
+ pure
+ $ Any
+ (intFormat to)
+ ( \dst ->
+ code
+ `snocOL`
+ -- W32 is the smallest width to convert to. Decrease width afterwards.
+ annExpr expr (FCVT FloatToInt (OpReg W32 dst) (OpReg from reg))
+ `appOL` signExtendAdjustPrecission W32 to dst dst -- (float convert (-> zero) signed)
+ )
+ MO_FS_Conv from to ->
+ pure
+ $ Any
+ (intFormat to)
+ ( \dst ->
+ code
+ `snocOL` annExpr expr (FCVT FloatToInt (OpReg to dst) (OpReg from reg))
+ `appOL` truncateReg from to dst -- (float convert (-> zero) signed)
+ )
+ MO_UU_Conv from to
+ | from <= to ->
+ pure
+ $ Any
+ (intFormat to)
+ ( \dst ->
+ code
+ `snocOL` annExpr e (MOV (OpReg to dst) (OpReg from reg))
+ )
+ MO_UU_Conv from to ->
+ pure
+ $ Any
+ (intFormat to)
+ ( \dst ->
+ code
+ `snocOL` annExpr e (MOV (OpReg from dst) (OpReg from reg))
+ `appOL` truncateReg from to dst
+ )
+ MO_SS_Conv from to -> ss_conv from to reg code
+ MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` annExpr e (FCVT FloatToFloat (OpReg to dst) (OpReg from reg)))
+ -- Conversions
+ -- TODO: Duplication with MO_UU_Conv
+ MO_XX_Conv from to
+ | to < from ->
+ pure
+ $ Any
+ (intFormat to)
+ ( \dst ->
+ code
+ `snocOL` annExpr e (MOV (OpReg from dst) (OpReg from reg))
+ `appOL` truncateReg from to dst
+ )
+ MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e
+ MO_AlignmentCheck align wordWidth -> do
+ reg <- getRegister' config plat e
+ addAlignmentCheck align wordWidth reg
+ x -> pprPanic ("getRegister' (monadic CmmMachOp): " ++ show x) (pdoc plat expr)
+ where
+ -- In the case of 16- or 8-bit values we need to sign-extend to 32-bits
+ -- See Note [Signed arithmetic on RISCV64].
+ negate code w reg = do
+ let w' = opRegWidth w
+ (reg', code_sx) <- signExtendReg w w' reg
+ return $ Any (intFormat w) $ \dst ->
+ code
+ `appOL` code_sx
+ `snocOL` NEG (OpReg w' dst) (OpReg w' reg')
+ `appOL` truncateReg w' w dst
+
+ ss_conv from to reg code
+ | from < to = do
+ pure $ Any (intFormat to) $ \dst ->
+ code
+ `appOL` signExtend from to reg dst
+ `appOL` truncateReg from to dst
+ | from > to =
+ pure $ Any (intFormat to) $ \dst ->
+ code
+ `appOL` toOL
+ [ ann
+ (text "MO_SS_Conv: narrow register signed" <+> ppr reg <+> ppr from <> text "->" <> ppr to)
+ (SLL (OpReg to dst) (OpReg from reg) (OpImm (ImmInt shift))),
+ -- signed right shift
+ SRA (OpReg to dst) (OpReg to dst) (OpImm (ImmInt shift))
+ ]
+ `appOL` truncateReg from to dst
+ | otherwise =
+ -- No conversion necessary: Just copy.
+ pure $ Any (intFormat from) $ \dst ->
+ code `snocOL` MOV (OpReg from dst) (OpReg from reg)
+ where
+ shift = 64 - (widthInBits from - widthInBits to)
+
+ -- Dyadic machops:
+ --
+ -- The general idea is:
+ -- compute x<i> <- x
+ -- compute x<j> <- y
+ -- OP x<r>, x<i>, x<j>
+ --
+ -- TODO: for now we'll only implement the 64bit versions. And rely on the
+ -- fallthrough to alert us if things go wrong!
+ -- OPTIMIZATION WARNING: Dyadic CmmMachOp destructuring
+ -- 0. TODO This should not exist! Rewrite: Reg +- 0 -> Reg
+ CmmMachOp (MO_Add _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'
+ CmmMachOp (MO_Sub _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'
+ -- 1. Compute Reg +/- n directly.
+ -- For Add/Sub we can directly encode 12bits, or 12bits lsl #12.
+ CmmMachOp (MO_Add w) [CmmReg reg, CmmLit (CmmInt n _)]
+ | fitsIn12bitImm n -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))
+ where
+ -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.
+ w' = formatToWidth (cmmTypeFormat (cmmRegType reg))
+ r' = getRegisterReg plat reg
+ CmmMachOp (MO_Sub w) [CmmReg reg, CmmLit (CmmInt n _)]
+ | fitsIn12bitImm n -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))
+ where
+ -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.
+ w' = formatToWidth (cmmTypeFormat (cmmRegType reg))
+ r' = getRegisterReg plat reg
+ CmmMachOp (MO_U_Quot w) [x, y] | w == W8 || w == W16 -> do
+ (reg_x, format_x, code_x) <- getSomeReg x
+ (reg_y, format_y, code_y) <- getSomeReg y
+ return
+ $ Any
+ (intFormat w)
+ ( \dst ->
+ code_x
+ `appOL` truncateReg (formatToWidth format_x) w reg_x
+ `appOL` code_y
+ `appOL` truncateReg (formatToWidth format_y) w reg_y
+ `snocOL` annExpr expr (DIVU (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))
+ )
+
+ -- 2. Shifts. x << n, x >> n.
+ CmmMachOp (MO_Shl w) [x, CmmLit (CmmInt n _)]
+ | w == W32,
+ 0 <= n,
+ n < 32 -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return
+ $ Any
+ (intFormat w)
+ ( \dst ->
+ code_x
+ `snocOL` annExpr expr (SLL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))
+ `appOL` truncateReg w w dst
+ )
+ CmmMachOp (MO_Shl w) [x, CmmLit (CmmInt n _)]
+ | w == W64,
+ 0 <= n,
+ n < 64 -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return
+ $ Any
+ (intFormat w)
+ ( \dst ->
+ code_x
+ `snocOL` annExpr expr (SLL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))
+ `appOL` truncateReg w w dst
+ )
+ CmmMachOp (MO_S_Shr w) [x, CmmLit (CmmInt n _)] | fitsIn12bitImm n -> do
+ (reg_x, format_x, code_x) <- getSomeReg x
+ (reg_x', code_x') <- signExtendReg (formatToWidth format_x) w reg_x
+ return
+ $ Any
+ (intFormat w)
+ ( \dst ->
+ code_x
+ `appOL` code_x'
+ `snocOL` annExpr expr (SRA (OpReg w dst) (OpReg w reg_x') (OpImm (ImmInteger n)))
+ )
+ CmmMachOp (MO_S_Shr w) [x, y] -> do
+ (reg_x, format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ (reg_x', code_x') <- signExtendReg (formatToWidth format_x) w reg_x
+ return
+ $ Any
+ (intFormat w)
+ ( \dst ->
+ code_x
+ `appOL` code_x'
+ `appOL` code_y
+ `snocOL` annExpr expr (SRA (OpReg w dst) (OpReg w reg_x') (OpReg w reg_y))
+ )
+ CmmMachOp (MO_U_Shr w) [x, CmmLit (CmmInt n _)]
+ | w == W8,
+ 0 <= n,
+ n < 8 -> do
+ (reg_x, format_x, code_x) <- getSomeReg x
+ return
+ $ Any
+ (intFormat w)
+ ( \dst ->
+ code_x
+ `appOL` truncateReg (formatToWidth format_x) w reg_x
+ `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))
+ )
+ CmmMachOp (MO_U_Shr w) [x, CmmLit (CmmInt n _)]
+ | w == W16,
+ 0 <= n,
+ n < 16 -> do
+ (reg_x, format_x, code_x) <- getSomeReg x
+ return
+ $ Any
+ (intFormat w)
+ ( \dst ->
+ code_x
+ `appOL` truncateReg (formatToWidth format_x) w reg_x
+ `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))
+ )
+ CmmMachOp (MO_U_Shr w) [x, y] | w == W8 || w == W16 -> do
+ (reg_x, format_x, code_x) <- getSomeReg x
+ (reg_y, _format_y, code_y) <- getSomeReg y
+ return
+ $ Any
+ (intFormat w)
+ ( \dst ->
+ code_x
+ `appOL` code_y
+ `appOL` truncateReg (formatToWidth format_x) w reg_x
+ `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))
+ )
+ CmmMachOp (MO_U_Shr w) [x, CmmLit (CmmInt n _)]
+ | w == W32,
+ 0 <= n,
+ n < 32 -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return
+ $ Any
+ (intFormat w)
+ ( \dst ->
+ code_x
+ `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))
+ )
+ CmmMachOp (MO_U_Shr w) [x, CmmLit (CmmInt n _)]
+ | w == W64,
+ 0 <= n,
+ n < 64 -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return
+ $ Any
+ (intFormat w)
+ ( \dst ->
+ code_x
+ `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))
+ )
+
+ -- 3. Logic &&, ||
+ CmmMachOp (MO_And w) [CmmReg reg, CmmLit (CmmInt n _)]
+ | fitsIn12bitImm n ->
+ return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (AND (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))
+ where
+ w' = formatToWidth (cmmTypeFormat (cmmRegType reg))
+ r' = getRegisterReg plat reg
+ CmmMachOp (MO_Or w) [CmmReg reg, CmmLit (CmmInt n _)]
+ | fitsIn12bitImm n ->
+ return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORI (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))
+ where
+ w' = formatToWidth (cmmTypeFormat (cmmRegType reg))
+ r' = getRegisterReg plat reg
+
+ -- Generic binary case.
+ CmmMachOp op [x, y] -> do
+ let -- A "plain" operation.
+ bitOp w op = do
+ -- compute x<m> <- x
+ -- compute x<o> <- y
+ -- <OP> x<n>, x<m>, x<o>
+ (reg_x, format_x, code_x) <- getSomeReg x
+ (reg_y, format_y, code_y) <- getSomeReg y
+ massertPpr (isIntFormat format_x == isIntFormat format_y) $ text "bitOp: incompatible"
+ return
+ $ Any
+ (intFormat w)
+ ( \dst ->
+ code_x
+ `appOL` code_y
+ `appOL` op (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)
+ )
+
+ -- A (potentially signed) integer operation.
+ -- In the case of 8- and 16-bit signed arithmetic we must first
+ -- sign-extend both arguments to 32-bits.
+ -- See Note [Signed arithmetic on RISCV64].
+ intOp is_signed w op = do
+ -- compute x<m> <- x
+ -- compute x<o> <- y
+ -- <OP> x<n>, x<m>, x<o>
+ (reg_x, format_x, code_x) <- getSomeReg x
+ (reg_y, format_y, code_y) <- getSomeReg y
+ massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int"
+ -- This is the width of the registers on which the operation
+ -- should be performed.
+ let w' = opRegWidth w
+ signExt r
+ | not is_signed = return (r, nilOL)
+ | otherwise = signExtendReg w w' r
+ (reg_x_sx, code_x_sx) <- signExt reg_x
+ (reg_y_sx, code_y_sx) <- signExt reg_y
+ return $ Any (intFormat w) $ \dst ->
+ code_x
+ `appOL` code_y
+ `appOL`
+ -- sign-extend both operands
+ code_x_sx
+ `appOL` code_y_sx
+ `appOL` op (OpReg w' dst) (OpReg w' reg_x_sx) (OpReg w' reg_y_sx)
+ `appOL` truncateReg w' w dst -- truncate back to the operand's original width
+ floatOp w op = do
+ (reg_fx, format_x, code_fx) <- getFloatReg x
+ (reg_fy, format_y, code_fy) <- getFloatReg y
+ massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatOp: non-float"
+ return
+ $ Any
+ (floatFormat w)
+ ( \dst ->
+ code_fx
+ `appOL` code_fy
+ `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy)
+ )
+
+ -- need a special one for conditionals, as they return ints
+ floatCond w op = do
+ (reg_fx, format_x, code_fx) <- getFloatReg x
+ (reg_fy, format_y, code_fy) <- getFloatReg y
+ massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatCond: non-float"
+ return
+ $ Any
+ (intFormat w)
+ ( \dst ->
+ code_fx
+ `appOL` code_fy
+ `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy)
+ )
+
+ case op of
+ -- Integer operations
+ -- Add/Sub should only be Integer Options.
+ MO_Add w -> intOp False w (\d x y -> unitOL $ annExpr expr (ADD d x y))
+ -- TODO: Handle sub-word case
+ MO_Sub w -> intOp False w (\d x y -> unitOL $ annExpr expr (SUB d x y))
+ -- N.B. We needn't sign-extend sub-word size (in)equality comparisons
+ -- since we don't care about ordering.
+ MO_Eq w -> bitOp w (\d x y -> unitOL $ annExpr expr (CSET d x y EQ))
+ MO_Ne w -> bitOp w (\d x y -> unitOL $ annExpr expr (CSET d x y NE))
+ -- Signed multiply/divide
+ MO_Mul w -> intOp True w (\d x y -> unitOL $ annExpr expr (MUL d x y))
+ MO_S_MulMayOflo w -> do_mul_may_oflo w x y
+ MO_S_Quot w -> intOp True w (\d x y -> unitOL $ annExpr expr (DIV d x y))
+ MO_S_Rem w -> intOp True w (\d x y -> unitOL $ annExpr expr (REM d x y))
+ -- Unsigned multiply/divide
+ MO_U_Quot w -> intOp False w (\d x y -> unitOL $ annExpr expr (DIVU d x y))
+ MO_U_Rem w -> intOp False w (\d x y -> unitOL $ annExpr expr (REMU d x y))
+ -- Signed comparisons
+ MO_S_Ge w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SGE))
+ MO_S_Le w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SLE))
+ MO_S_Gt w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SGT))
+ MO_S_Lt w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SLT))
+ -- Unsigned comparisons
+ MO_U_Ge w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y UGE))
+ MO_U_Le w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y ULE))
+ MO_U_Gt w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y UGT))
+ MO_U_Lt w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y ULT))
+ -- Floating point arithmetic
+ MO_F_Add w -> floatOp w (\d x y -> unitOL $ annExpr expr (ADD d x y))
+ MO_F_Sub w -> floatOp w (\d x y -> unitOL $ annExpr expr (SUB d x y))
+ MO_F_Mul w -> floatOp w (\d x y -> unitOL $ annExpr expr (MUL d x y))
+ MO_F_Quot w -> floatOp w (\d x y -> unitOL $ annExpr expr (DIV d x y))
+ -- Floating point comparison
+ MO_F_Eq w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y EQ))
+ MO_F_Ne w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y NE))
+ MO_F_Ge w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FGE))
+ MO_F_Le w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FLE)) -- x <= y <=> y > x
+ MO_F_Gt w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FGT))
+ MO_F_Lt w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FLT)) -- x < y <=> y >= x
+
+ -- Bitwise operations
+ MO_And w -> bitOp w (\d x y -> unitOL $ annExpr expr (AND d x y))
+ MO_Or w -> bitOp w (\d x y -> unitOL $ annExpr expr (OR d x y))
+ MO_Xor w -> bitOp w (\d x y -> unitOL $ annExpr expr (XOR d x y))
+ MO_Shl w -> intOp False w (\d x y -> unitOL $ annExpr expr (SLL d x y))
+ MO_U_Shr w -> intOp False w (\d x y -> unitOL $ annExpr expr (SRL d x y))
+ MO_S_Shr w -> intOp True w (\d x y -> unitOL $ annExpr expr (SRA d x y))
+ op -> pprPanic "getRegister' (unhandled dyadic CmmMachOp): " $ pprMachOp op <+> text "in" <+> pdoc plat expr
+
+ -- Generic ternary case.
+ CmmMachOp op [x, y, z] ->
+ case op of
+ -- Floating-point fused multiply-add operations
+ --
+ -- x86 fmadd x * y + z <=> RISCV64 fmadd : d = r1 * r2 + r3
+ -- x86 fmsub x * y - z <=> RISCV64 fnmsub: d = r1 * r2 - r3
+ -- x86 fnmadd - x * y + z <=> RISCV64 fmsub : d = - r1 * r2 + r3
+ -- x86 fnmsub - x * y - z <=> RISCV64 fnmadd: d = - r1 * r2 - r3
+ MO_FMA var w -> case var of
+ FMAdd -> float3Op w (\d n m a -> unitOL $ FMA FMAdd d n m a)
+ FMSub -> float3Op w (\d n m a -> unitOL $ FMA FMSub d n m a)
+ FNMAdd -> float3Op w (\d n m a -> unitOL $ FMA FNMSub d n m a)
+ FNMSub -> float3Op w (\d n m a -> unitOL $ FMA FNMAdd d n m a)
+ _ ->
+ pprPanic "getRegister' (unhandled ternary CmmMachOp): "
+ $ pprMachOp op
+ <+> text "in"
+ <+> pdoc plat expr
+ where
+ float3Op w op = do
+ (reg_fx, format_x, code_fx) <- getFloatReg x
+ (reg_fy, format_y, code_fy) <- getFloatReg y
+ (reg_fz, format_z, code_fz) <- getFloatReg z
+ massertPpr (isFloatFormat format_x && isFloatFormat format_y && isFloatFormat format_z)
+ $ text "float3Op: non-float"
+ pure
+ $ Any (floatFormat w)
+ $ \dst ->
+ code_fx
+ `appOL` code_fy
+ `appOL` code_fz
+ `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy) (OpReg w reg_fz)
+ CmmMachOp _op _xs ->
+ pprPanic "getRegister' (variadic CmmMachOp): " (pdoc plat expr)
+ where
+ isNbitEncodeable :: Int -> Integer -> Bool
+ isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)
+ -- N.B. MUL does not set the overflow flag.
+ -- Return 0 when the operation cannot overflow, /= 0 otherwise
+ do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
+ do_mul_may_oflo w _x _y | w > W64 = pprPanic "Cannot multiply larger than 64bit" (ppr w)
+ do_mul_may_oflo w@W64 x y = do
+ (reg_x, format_x, code_x) <- getSomeReg x
+ (reg_y, format_y, code_y) <- getSomeReg y
+ -- TODO: Can't we clobber reg_x and reg_y to save registers?
+ lo <- getNewRegNat II64
+ hi <- getNewRegNat II64
+ -- TODO: Overhaul CSET: 3rd operand isn't needed for SNEZ
+ let nonSense = OpImm (ImmInt 0)
+ pure
+ $ Any
+ (intFormat w)
+ ( \dst ->
+ code_x
+ `appOL` signExtend (formatToWidth format_x) W64 reg_x reg_x
+ `appOL` code_y
+ `appOL` signExtend (formatToWidth format_y) W64 reg_y reg_y
+ `appOL` toOL
+ [ annExpr expr (MULH (OpReg w hi) (OpReg w reg_x) (OpReg w reg_y)),
+ MUL (OpReg w lo) (OpReg w reg_x) (OpReg w reg_y),
+ SRA (OpReg w lo) (OpReg w lo) (OpImm (ImmInt (widthInBits W64 - 1))),
+ ann
+ (text "Set flag if result of MULH contains more than sign bits.")
+ (XOR (OpReg w hi) (OpReg w hi) (OpReg w lo)),
+ CSET (OpReg w dst) (OpReg w hi) nonSense NE
+ ]
+ )
+ do_mul_may_oflo w x y = do
+ (reg_x, format_x, code_x) <- getSomeReg x
+ (reg_y, format_y, code_y) <- getSomeReg y
+ let width_x = formatToWidth format_x
+ width_y = formatToWidth format_y
+ if w > width_x && w > width_y
+ then
+ pure
+ $ Any
+ (intFormat w)
+ ( \dst ->
+ -- 8bit * 8bit cannot overflow 16bit
+ -- 16bit * 16bit cannot overflow 32bit
+ -- 32bit * 32bit cannot overflow 64bit
+ unitOL $ annExpr expr (ADD (OpReg w dst) zero (OpImm (ImmInt 0)))
+ )
+ else do
+ let use32BitMul = w <= W32 && width_x <= W32 && width_y <= W32
+ nonSense = OpImm (ImmInt 0)
+ if use32BitMul
+ then do
+ narrowedReg <- getNewRegNat II64
+ pure
+ $ Any
+ (intFormat w)
+ ( \dst ->
+ code_x
+ `appOL` signExtend (formatToWidth format_x) W32 reg_x reg_x
+ `appOL` code_y
+ `appOL` signExtend (formatToWidth format_y) W32 reg_y reg_y
+ `snocOL` annExpr expr (MUL (OpReg W32 dst) (OpReg W32 reg_x) (OpReg W32 reg_y))
+ `appOL` signExtendAdjustPrecission W32 w dst narrowedReg
+ `appOL` toOL
+ [ ann
+ (text "Check if the multiplied value fits in the narrowed register")
+ (SUB (OpReg w dst) (OpReg w dst) (OpReg w narrowedReg)),
+ CSET (OpReg w dst) (OpReg w dst) nonSense NE
+ ]
+ )
+ else
+ pure
+ $ Any
+ (intFormat w)
+ ( \dst ->
+ -- Do not handle this unlikely case. Just tell that it may overflow.
+ unitOL $ annExpr expr (ADD (OpReg w dst) zero (OpImm (ImmInt 1)))
+ )
+
+-- | Instructions to sign-extend the value in the given register from width @w@
+-- up to width @w'@.
+signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr)
+signExtendReg w _w' r | w == W64 = pure (r, nilOL)
+signExtendReg w w' r = do
+ r' <- getNewRegNat (intFormat w')
+ let instrs = signExtend w w' r r'
+ pure (r', instrs)
+
+-- | Sign extends to 64bit, if needed
+--
+-- Source `Reg` @r@ stays untouched, while the conversion happens on destination
+-- `Reg` @r'@.
+signExtend :: Width -> Width -> Reg -> Reg -> OrdList Instr
+signExtend w w' _r _r' | w > w' = pprPanic "This is not a sign extension, but a truncation." $ ppr w <> text "->" <+> ppr w'
+signExtend w w' _r _r' | w > W64 || w' > W64 = pprPanic "Unexpected width (max is 64bit):" $ ppr w <> text "->" <+> ppr w'
+signExtend w w' r r' | w == W64 && w' == W64 && r == r' = nilOL
+signExtend w w' r r' | w == W64 && w' == W64 = unitOL $ MOV (OpReg w' r') (OpReg w r)
+signExtend w w' r r'
+ | w == W32 && w' == W64 =
+ unitOL
+ $ ann
+ (text "sign-extend register (SEXT.W)" <+> ppr r <+> ppr w <> text "->" <> ppr w')
+ -- `ADDIW r r 0` is the pseudo-op SEXT.W
+ (ADD (OpReg w' r') (OpReg w r) (OpImm (ImmInt 0)))
+signExtend w w' r r' =
+ toOL
+ [ ann
+ (text "narrow register signed" <+> ppr r <> char ':' <> ppr w <> text "->" <> ppr r <> char ':' <> ppr w')
+ (SLL (OpReg w' r') (OpReg w r) (OpImm (ImmInt shift))),
+ -- signed (arithmetic) right shift
+ SRA (OpReg w' r') (OpReg w' r') (OpImm (ImmInt shift))
+ ]
+ where
+ shift = 64 - widthInBits w
+
+-- | Sign extends to 64bit, if needed and reduces the precission to the target `Width` (@w'@)
+--
+-- Source `Reg` @r@ stays untouched, while the conversion happens on destination
+-- `Reg` @r'@.
+signExtendAdjustPrecission :: Width -> Width -> Reg -> Reg -> OrdList Instr
+signExtendAdjustPrecission w w' _r _r' | w > W64 || w' > W64 = pprPanic "Unexpected width (max is 64bit):" $ ppr w <> text "->" <+> ppr w'
+signExtendAdjustPrecission w w' r r' | w == W64 && w' == W64 && r == r' = nilOL
+signExtendAdjustPrecission w w' r r' | w == W64 && w' == W64 = unitOL $ MOV (OpReg w' r') (OpReg w r)
+signExtendAdjustPrecission w w' r r'
+ | w == W32 && w' == W64 =
+ unitOL
+ $ ann
+ (text "sign-extend register (SEXT.W)" <+> ppr r <+> ppr w <> text "->" <> ppr w')
+ -- `ADDIW r r 0` is the pseudo-op SEXT.W
+ (ADD (OpReg w' r') (OpReg w r) (OpImm (ImmInt 0)))
+signExtendAdjustPrecission w w' r r'
+ | w > w' =
+ toOL
+ [ ann
+ (text "narrow register signed" <+> ppr r <> char ':' <> ppr w <> text "->" <> ppr r <> char ':' <> ppr w')
+ (SLL (OpReg w' r') (OpReg w r) (OpImm (ImmInt shift))),
+ -- signed (arithmetic) right shift
+ SRA (OpReg w' r') (OpReg w' r') (OpImm (ImmInt shift))
+ ]
+ where
+ shift = 64 - widthInBits w'
+signExtendAdjustPrecission w w' r r' =
+ toOL
+ [ ann
+ (text "sign extend register" <+> ppr r <> char ':' <> ppr w <> text "->" <> ppr r <> char ':' <> ppr w')
+ (SLL (OpReg w' r') (OpReg w r) (OpImm (ImmInt shift))),
+ -- signed (arithmetic) right shift
+ SRA (OpReg w' r') (OpReg w' r') (OpImm (ImmInt shift))
+ ]
+ where
+ shift = 64 - widthInBits w
+
+-- | Instructions to truncate the value in the given register from width @w@
+-- to width @w'@.
+--
+-- In other words, it just cuts the width out of the register. N.B.: This
+-- ignores signedness (no sign extension takes place)!
+truncateReg :: Width -> Width -> Reg -> OrdList Instr
+truncateReg _w w' _r | w' == W64 = nilOL
+truncateReg _w w' r | w' > W64 = pprPanic "Cannot truncate to width bigger than register size (max is 64bit):" $ text (show r) <> char ':' <+> ppr w'
+truncateReg w _w' r | w > W64 = pprPanic "Unexpected register size (max is 64bit):" $ text (show r) <> char ':' <+> ppr w
+truncateReg w w' r =
+ toOL
+ [ ann
+ (text "truncate register" <+> ppr r <+> ppr w <> text "->" <> ppr w')
+ (SLL (OpReg w' r) (OpReg w r) (OpImm (ImmInt shift))),
+ -- SHL ignores signedness!
+ SRL (OpReg w' r) (OpReg w r) (OpImm (ImmInt shift))
+ ]
+ where
+ shift = 64 - widthInBits w'
+
+-- | Given a 'Register', produce a new 'Register' with an instruction block
+-- which will check the value for alignment. Used for @-falignment-sanitisation@.
+addAlignmentCheck :: Int -> Width -> Register -> NatM Register
+addAlignmentCheck align wordWidth reg = do
+ jumpReg <- getNewRegNat II64
+ cmpReg <- getNewRegNat II64
+ okayLblId <- getBlockIdNat
+
+ pure $ case reg of
+ Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt jumpReg cmpReg okayLblId reg)
+ Any fmt f -> Any fmt (\reg -> f reg `appOL` check fmt jumpReg cmpReg okayLblId reg)
+ where
+ check :: Format -> Reg -> Reg -> BlockId -> Reg -> InstrBlock
+ check fmt jumpReg cmpReg okayLblId reg =
+ let width = formatToWidth fmt
+ in assert (not $ isFloatFormat fmt)
+ $ toOL
+ [ ann
+ (text "Alignment check - alignment: " <> int align <> text ", word width: " <> text (show wordWidth))
+ (AND (OpReg width cmpReg) (OpReg width reg) (OpImm $ ImmInt $ align - 1)),
+ BCOND EQ (OpReg width cmpReg) zero (TBlock okayLblId),
+ COMMENT (text "Alignment check failed"),
+ LDR II64 (OpReg W64 jumpReg) (OpImm $ ImmCLbl mkBadAlignmentLabel),
+ B (TReg jumpReg),
+ NEWBLOCK okayLblId
+ ]
+
+-- -----------------------------------------------------------------------------
+-- The 'Amode' type: Memory addressing modes passed up the tree.
+data Amode = Amode AddrMode InstrBlock
+
+-- | Provide the value of a `CmmExpr` with an `Amode`
+--
+-- N.B. this function should be used to provide operands to load and store
+-- instructions with signed 12bit wide immediates (S & I types). For other
+-- immediate sizes and formats (e.g. B type uses multiples of 2) this function
+-- would need to be adjusted.
+getAmode ::
+ Platform ->
+ -- | width of loaded value
+ Width ->
+ CmmExpr ->
+ NatM Amode
+-- TODO: Specialize stuff we can destructure here.
+
+-- LDR/STR: Immediate can be represented with 12bits
+getAmode platform w (CmmRegOff reg off)
+ | w <= W64,
+ fitsIn12bitImm off =
+ return $ Amode (AddrRegImm reg' off') nilOL
+ where
+ reg' = getRegisterReg platform reg
+ off' = ImmInt off
+
+-- For Stores we often see something like this:
+-- CmmStore (CmmMachOp (MO_Add w) [CmmLoad expr, CmmLit (CmmInt n w')]) (expr2)
+-- E.g. a CmmStoreOff really. This can be translated to `str $expr2, [$expr, #n ]
+-- for `n` in range.
+getAmode _platform _ (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')])
+ | fitsIn12bitImm off =
+ do
+ (reg, _format, code) <- getSomeReg expr
+ return $ Amode (AddrRegImm reg (ImmInteger off)) code
+getAmode _platform _ (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')])
+ | fitsIn12bitImm (-off) =
+ do
+ (reg, _format, code) <- getSomeReg expr
+ return $ Amode (AddrRegImm reg (ImmInteger (-off))) code
+
+-- Generic case
+getAmode _platform _ expr =
+ do
+ (reg, _format, code) <- getSomeReg expr
+ return $ Amode (AddrReg reg) code
+
+-- -----------------------------------------------------------------------------
+-- Generating assignments
+
+-- Assignments are really at the heart of the whole code generation
+-- business. Almost all top-level nodes of any real importance are
+-- assignments, which correspond to loads, stores, or register
+-- transfers. If we're really lucky, some of the register transfers
+-- will go away, because we can use the destination register to
+-- complete the code generation for the right hand side. This only
+-- fails when the right hand side is forced into a fixed register
+-- (e.g. the result of a call).
+
+assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock
+assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock
+assignMem_IntCode rep addrE srcE =
+ do
+ (src_reg, _format, code) <- getSomeReg srcE
+ platform <- getPlatform
+ let w = formatToWidth rep
+ Amode addr addr_code <- getAmode platform w addrE
+ return $ COMMENT (text "CmmStore" <+> parens (text (show addrE)) <+> parens (text (show srcE)))
+ `consOL` ( code
+ `appOL` addr_code
+ `snocOL` STR rep (OpReg w src_reg) (OpAddr addr)
+ )
+
+assignReg_IntCode _ reg src =
+ do
+ platform <- getPlatform
+ let dst = getRegisterReg platform reg
+ 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 ->
+ COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src)))
+ `consOL` ( fcode
+ `snocOL` MOV (OpReg (formatToWidth format) dst) (OpReg (formatToWidth format) freg)
+ )
+
+-- Let's treat Floating point stuff
+-- as integer code for now. Opaque.
+assignMem_FltCode = assignMem_IntCode
+
+assignReg_FltCode = assignReg_IntCode
+
+-- -----------------------------------------------------------------------------
+-- Jumps
+-- AArch64 has 26bits for targets, whereas RiscV only has 20.
+-- Thus we need to distinguish between far (outside of the)
+-- current compilation unit. And regular branches.
+-- RiscV has ±2MB of displacement, whereas AArch64 has ±128MB.
+-- Thus for most branches we can get away with encoding it
+-- directly in the instruction rather than always loading the
+-- address into a register and then using that to jump.
+-- Under the assumption that our linked build product is less than
+-- ~2*128MB of TEXT, and there are no jump that span the whole
+-- TEXT segment.
+-- Something where riscv's compressed instruction might come in
+-- handy.
+genJump :: CmmExpr {-the branch target-} -> NatM InstrBlock
+genJump expr = do
+ (target, _format, code) <- getSomeReg expr
+ return (code `appOL` unitOL (annExpr expr (B (TReg target))))
+
+-- -----------------------------------------------------------------------------
+-- Unconditional branches
+genBranch :: BlockId -> NatM InstrBlock
+genBranch = return . toOL . mkJumpInstr
+
+-- -----------------------------------------------------------------------------
+-- Conditional branches
+genCondJump ::
+ BlockId ->
+ CmmExpr ->
+ NatM InstrBlock
+genCondJump bid expr = do
+ case expr of
+ -- Optimized == 0 case.
+ CmmMachOp (MO_Eq w) [x, CmmLit (CmmInt 0 _)] -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ code_x `snocOL` annExpr expr (BCOND EQ zero (OpReg w reg_x) (TBlock bid))
+
+ -- Optimized /= 0 case.
+ CmmMachOp (MO_Ne w) [x, CmmLit (CmmInt 0 _)] -> do
+ (reg_x, _format_x, code_x) <- getSomeReg x
+ return $ code_x `snocOL` annExpr expr (BCOND NE zero (OpReg w reg_x) (TBlock bid))
+
+ -- Generic case.
+ CmmMachOp mop [x, y] -> do
+ let ubcond w cmp = do
+ -- compute both sides.
+ (reg_x, format_x, code_x) <- getSomeReg x
+ (reg_y, format_y, code_y) <- getSomeReg y
+ let x' = OpReg w reg_x
+ y' = OpReg w reg_y
+ return $ case w of
+ w
+ | w == W8 || w == W16 ->
+ code_x
+ `appOL` truncateReg (formatToWidth format_x) w reg_x
+ `appOL` code_y
+ `appOL` truncateReg (formatToWidth format_y) w reg_y
+ `appOL` code_y
+ `snocOL` annExpr expr (BCOND cmp x' y' (TBlock bid))
+ _ ->
+ code_x
+ `appOL` code_y
+ `snocOL` annExpr expr (BCOND cmp x' y' (TBlock bid))
+
+ sbcond w cmp = do
+ -- compute both sides.
+ (reg_x, format_x, code_x) <- getSomeReg x
+ (reg_y, format_y, code_y) <- getSomeReg y
+ let x' = OpReg w reg_x
+ y' = OpReg w reg_y
+ return $ case w of
+ w
+ | w `elem` [W8, W16, W32] ->
+ code_x
+ `appOL` signExtend (formatToWidth format_x) W64 reg_x reg_x
+ `appOL` code_y
+ `appOL` signExtend (formatToWidth format_y) W64 reg_y reg_y
+ `appOL` unitOL (annExpr expr (BCOND cmp x' y' (TBlock bid)))
+ _ -> code_x `appOL` code_y `appOL` unitOL (annExpr expr (BCOND cmp x' y' (TBlock bid)))
+
+ fbcond w cmp = do
+ -- ensure we get float regs
+ (reg_fx, _format_fx, code_fx) <- getFloatReg x
+ (reg_fy, _format_fy, code_fy) <- getFloatReg y
+ condOpReg <- OpReg W64 <$> getNewRegNat II64
+ oneReg <- getNewRegNat II64
+ return $ code_fx
+ `appOL` code_fy
+ `snocOL` annExpr expr (CSET condOpReg (OpReg w reg_fx) (OpReg w reg_fy) cmp)
+ `snocOL` MOV (OpReg W64 oneReg) (OpImm (ImmInt 1))
+ `snocOL` BCOND EQ condOpReg (OpReg w oneReg) (TBlock bid)
+
+ case mop of
+ MO_F_Eq w -> fbcond w EQ
+ MO_F_Ne w -> fbcond w NE
+ MO_F_Gt w -> fbcond w FGT
+ MO_F_Ge w -> fbcond w FGE
+ MO_F_Lt w -> fbcond w FLT
+ MO_F_Le w -> fbcond w FLE
+ MO_Eq w -> sbcond w EQ
+ MO_Ne w -> sbcond w NE
+ MO_S_Gt w -> sbcond w SGT
+ MO_S_Ge w -> sbcond w SGE
+ MO_S_Lt w -> sbcond w SLT
+ MO_S_Le w -> sbcond w SLE
+ MO_U_Gt w -> ubcond w UGT
+ MO_U_Ge w -> ubcond w UGE
+ MO_U_Lt w -> ubcond w ULT
+ MO_U_Le w -> ubcond w ULE
+ _ -> pprPanic "RV64.genCondJump:case mop: " (text $ show expr)
+ _ -> pprPanic "RV64.genCondJump: " (text $ show expr)
+
+-- | Generate conditional branching instructions
+--
+-- This is basically an "if with else" statement.
+genCondBranch ::
+ -- | the true branch target
+ BlockId ->
+ -- | the false branch target
+ BlockId ->
+ -- | the condition on which to branch
+ CmmExpr ->
+ -- | Instructions
+ NatM InstrBlock
+genCondBranch true false expr =
+ appOL
+ <$> genCondJump true expr
+ <*> genBranch false
+
+-- -----------------------------------------------------------------------------
+-- Generating C calls
+
+-- | Generate a call to a C function.
+--
+-- - Integer values are passed in GP registers a0-a7.
+-- - Floating point values are passed in FP registers fa0-fa7.
+-- - If there are no free floating point registers, the FP values are passed in GP registers.
+-- - If all GP registers are taken, the values are spilled as whole words (!) onto the stack.
+-- - For integers/words, the return value is in a0.
+-- - The return value is in fa0 if the return type is a floating point value.
+genCCall ::
+ ForeignTarget -> -- function to call
+ [CmmFormal] -> -- where to put the result
+ [CmmActual] -> -- arguments (of mixed type)
+ NatM InstrBlock
+-- TODO: Specialize where we can.
+-- Generic impl
+genCCall target@(ForeignTarget expr _cconv) dest_regs arg_regs = do
+ -- we want to pass arg_regs into allArgRegs
+ -- The target :: ForeignTarget call can either
+ -- be a foreign procedure with an address expr
+ -- and a calling convention.
+ (call_target_reg, call_target_code) <-
+ -- Compute the address of the call target into a register. This
+ -- addressing enables us to jump through the whole address space
+ -- without further ado. PC-relative addressing would involve
+ -- instructions to do similar, though.
+ do
+ (reg, _format, reg_code) <- getSomeReg expr
+ pure (reg, reg_code)
+ -- compute the code and register logic for all arg_regs.
+ -- this will give us the format information to match on.
+ arg_regs' <- mapM getSomeReg arg_regs
+
+ -- Now this is stupid. Our Cmm expressions doesn't carry the proper sizes
+ -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in
+ -- STG; this then breaks packing of stack arguments, if we need to pack
+ -- for the pcs, e.g. darwinpcs. Option one would be to fix the Int type
+ -- in Cmm proper. Option two, which we choose here is to use extended Hint
+ -- information to contain the size information and use that when packing
+ -- arguments, spilled onto the stack.
+ let (_res_hints, arg_hints) = foreignTargetHints target
+ arg_regs'' = zipWith (\(r, f, c) h -> (r, f, h, c)) arg_regs' arg_hints
+
+ (stackSpaceWords, passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL
+
+ readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL
+
+ let moveStackDown 0 =
+ toOL
+ [ PUSH_STACK_FRAME,
+ DELTA (-16)
+ ]
+ moveStackDown i | odd i = moveStackDown (i + 1)
+ moveStackDown i =
+ toOL
+ [ PUSH_STACK_FRAME,
+ SUB (OpReg W64 spMachReg) (OpReg W64 spMachReg) (OpImm (ImmInt (8 * i))),
+ DELTA (-8 * i - 16)
+ ]
+ moveStackUp 0 =
+ toOL
+ [ POP_STACK_FRAME,
+ DELTA 0
+ ]
+ moveStackUp i | odd i = moveStackUp (i + 1)
+ moveStackUp i =
+ toOL
+ [ ADD (OpReg W64 spMachReg) (OpReg W64 spMachReg) (OpImm (ImmInt (8 * i))),
+ POP_STACK_FRAME,
+ DELTA 0
+ ]
+
+ let code =
+ call_target_code -- compute the label (possibly into a register)
+ `appOL` moveStackDown stackSpaceWords
+ `appOL` passArgumentsCode -- put the arguments into x0, ...
+ `snocOL` BL call_target_reg passRegs -- branch and link (C calls aren't tail calls, but return)
+ `appOL` readResultsCode -- parse the results into registers
+ `appOL` moveStackUp stackSpaceWords
+ return code
+ where
+ -- Implementiation of the RISCV ABI calling convention.
+ -- https://github.com/riscv-non-isa/riscv-elf-psabi-doc/blob/948463cd5dbebea7c1869e20146b17a2cc8fda2f/riscv-cc.adoc#integer-calling-convention
+ passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)
+ -- Base case: no more arguments to pass (left)
+ passArguments _ _ [] stackSpaceWords accumRegs accumCode = return (stackSpaceWords, accumRegs, accumCode)
+ -- Still have GP regs, and we want to pass an GP argument.
+ passArguments (gpReg : gpRegs) fpRegs ((r, format, hint, code_r) : args) stackSpaceWords accumRegs accumCode | isIntFormat format = do
+ -- RISCV64 Integer Calling Convention: "When passed in registers or on the
+ -- stack, integer scalars narrower than XLEN bits are widened according to
+ -- the sign of their type up to 32 bits, then sign-extended to XLEN bits."
+ let w = formatToWidth format
+ assignArg =
+ if hint == SignedHint
+ then
+ COMMENT (text "Pass gp argument sign-extended (SignedHint): " <> ppr r)
+ `consOL` signExtend w W64 r gpReg
+ else
+ toOL
+ [ COMMENT (text "Pass gp argument sign-extended (SignedHint): " <> ppr r),
+ MOV (OpReg w gpReg) (OpReg w r)
+ ]
+ accumCode' =
+ accumCode
+ `appOL` code_r
+ `appOL` assignArg
+ passArguments gpRegs fpRegs args stackSpaceWords (gpReg : accumRegs) accumCode'
+
+ -- Still have FP regs, and we want to pass an FP argument.
+ passArguments gpRegs (fpReg : fpRegs) ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isFloatFormat format = do
+ let w = formatToWidth format
+ mov = MOV (OpReg w fpReg) (OpReg w r)
+ accumCode' =
+ accumCode
+ `appOL` code_r
+ `snocOL` ann (text "Pass fp argument: " <> ppr r) mov
+ passArguments gpRegs fpRegs args stackSpaceWords (fpReg : accumRegs) accumCode'
+
+ -- No mor regs left to pass. Must pass on stack.
+ passArguments [] [] ((r, format, hint, code_r) : args) stackSpaceWords accumRegs accumCode = do
+ let w = formatToWidth format
+ spOffet = 8 * stackSpaceWords
+ str = STR format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet)))
+ stackCode =
+ if hint == SignedHint
+ then
+ code_r
+ `appOL` signExtend w W64 r tmpReg
+ `snocOL` ann (text "Pass signed argument (size " <> ppr w <> text ") on the stack: " <> ppr tmpReg) str
+ else
+ code_r
+ `snocOL` ann (text "Pass unsigned argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str
+ passArguments [] [] args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode)
+
+ -- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then.
+ passArguments [] fpRegs ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isIntFormat format = do
+ let w = formatToWidth format
+ spOffet = 8 * stackSpaceWords
+ str = STR format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet)))
+ stackCode =
+ code_r
+ `snocOL` ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str
+ passArguments [] fpRegs args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode)
+
+ -- Still have gpRegs left, but want to pass a FP argument. Must be passed in gpReg then.
+ passArguments (gpReg : gpRegs) [] ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isFloatFormat format = do
+ let w = formatToWidth format
+ mov = MOV (OpReg w gpReg) (OpReg w r)
+ accumCode' =
+ accumCode
+ `appOL` code_r
+ `snocOL` ann (text "Pass fp argument in gpReg: " <> ppr r) mov
+ passArguments gpRegs [] args stackSpaceWords (gpReg : accumRegs) accumCode'
+ passArguments _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state")
+
+ readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg] -> InstrBlock -> NatM InstrBlock
+ readResults _ _ [] _ accumCode = return accumCode
+ readResults [] _ _ _ _ = do
+ platform <- getPlatform
+ pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target)
+ readResults _ [] _ _ _ = do
+ platform <- getPlatform
+ pprPanic "genCCall, out of fp registers when reading results" (pdoc platform target)
+ readResults (gpReg : gpRegs) (fpReg : fpRegs) (dst : dsts) accumRegs accumCode = do
+ -- gp/fp reg -> dst
+ platform <- getPlatform
+ let rep = cmmRegType (CmmLocal dst)
+ format = cmmTypeFormat rep
+ w = cmmRegWidth (CmmLocal dst)
+ r_dst = getRegisterReg platform (CmmLocal dst)
+ if isFloatFormat format
+ then readResults (gpReg : gpRegs) fpRegs dsts (fpReg : accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg))
+ else
+ readResults gpRegs (fpReg : fpRegs) dsts (gpReg : accumRegs)
+ $ accumCode
+ `snocOL` MOV (OpReg w r_dst) (OpReg w gpReg)
+ `appOL`
+ -- truncate, otherwise an unexpectedly big value might be used in upfollowing calculations
+ truncateReg W64 w r_dst
+genCCall (PrimTarget mop) dest_regs arg_regs = do
+ case mop of
+ MO_F32_Fabs
+ | [arg_reg] <- arg_regs,
+ [dest_reg] <- dest_regs ->
+ unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg
+ MO_F64_Fabs
+ | [arg_reg] <- arg_regs,
+ [dest_reg] <- dest_regs ->
+ unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg
+ -- 64 bit float ops
+ MO_F64_Pwr -> mkCCall "pow"
+ MO_F64_Sin -> mkCCall "sin"
+ MO_F64_Cos -> mkCCall "cos"
+ MO_F64_Tan -> mkCCall "tan"
+ MO_F64_Sinh -> mkCCall "sinh"
+ MO_F64_Cosh -> mkCCall "cosh"
+ MO_F64_Tanh -> mkCCall "tanh"
+ MO_F64_Asin -> mkCCall "asin"
+ MO_F64_Acos -> mkCCall "acos"
+ MO_F64_Atan -> mkCCall "atan"
+ MO_F64_Asinh -> mkCCall "asinh"
+ MO_F64_Acosh -> mkCCall "acosh"
+ MO_F64_Atanh -> mkCCall "atanh"
+ MO_F64_Log -> mkCCall "log"
+ MO_F64_Log1P -> mkCCall "log1p"
+ MO_F64_Exp -> mkCCall "exp"
+ MO_F64_ExpM1 -> mkCCall "expm1"
+ MO_F64_Fabs -> mkCCall "fabs"
+ MO_F64_Sqrt -> mkCCall "sqrt"
+ -- 32 bit float ops
+ MO_F32_Pwr -> mkCCall "powf"
+ MO_F32_Sin -> mkCCall "sinf"
+ MO_F32_Cos -> mkCCall "cosf"
+ MO_F32_Tan -> mkCCall "tanf"
+ MO_F32_Sinh -> mkCCall "sinhf"
+ MO_F32_Cosh -> mkCCall "coshf"
+ MO_F32_Tanh -> mkCCall "tanhf"
+ MO_F32_Asin -> mkCCall "asinf"
+ MO_F32_Acos -> mkCCall "acosf"
+ MO_F32_Atan -> mkCCall "atanf"
+ MO_F32_Asinh -> mkCCall "asinhf"
+ MO_F32_Acosh -> mkCCall "acoshf"
+ MO_F32_Atanh -> mkCCall "atanhf"
+ MO_F32_Log -> mkCCall "logf"
+ MO_F32_Log1P -> mkCCall "log1pf"
+ MO_F32_Exp -> mkCCall "expf"
+ MO_F32_ExpM1 -> mkCCall "expm1f"
+ MO_F32_Fabs -> mkCCall "fabsf"
+ MO_F32_Sqrt -> mkCCall "sqrtf"
+ -- 64-bit primops
+ MO_I64_ToI -> mkCCall "hs_int64ToInt"
+ MO_I64_FromI -> mkCCall "hs_intToInt64"
+ MO_W64_ToW -> mkCCall "hs_word64ToWord"
+ MO_W64_FromW -> mkCCall "hs_wordToWord64"
+ MO_x64_Neg -> mkCCall "hs_neg64"
+ MO_x64_Add -> mkCCall "hs_add64"
+ MO_x64_Sub -> mkCCall "hs_sub64"
+ MO_x64_Mul -> mkCCall "hs_mul64"
+ MO_I64_Quot -> mkCCall "hs_quotInt64"
+ MO_I64_Rem -> mkCCall "hs_remInt64"
+ MO_W64_Quot -> mkCCall "hs_quotWord64"
+ MO_W64_Rem -> mkCCall "hs_remWord64"
+ MO_x64_And -> mkCCall "hs_and64"
+ MO_x64_Or -> mkCCall "hs_or64"
+ MO_x64_Xor -> mkCCall "hs_xor64"
+ MO_x64_Not -> mkCCall "hs_not64"
+ MO_x64_Shl -> mkCCall "hs_uncheckedShiftL64"
+ MO_I64_Shr -> mkCCall "hs_uncheckedIShiftRA64"
+ MO_W64_Shr -> mkCCall "hs_uncheckedShiftRL64"
+ MO_x64_Eq -> mkCCall "hs_eq64"
+ MO_x64_Ne -> mkCCall "hs_ne64"
+ MO_I64_Ge -> mkCCall "hs_geInt64"
+ MO_I64_Gt -> mkCCall "hs_gtInt64"
+ MO_I64_Le -> mkCCall "hs_leInt64"
+ MO_I64_Lt -> mkCCall "hs_ltInt64"
+ MO_W64_Ge -> mkCCall "hs_geWord64"
+ MO_W64_Gt -> mkCCall "hs_gtWord64"
+ MO_W64_Le -> mkCCall "hs_leWord64"
+ MO_W64_Lt -> mkCCall "hs_ltWord64"
+ -- Conversion
+ MO_UF_Conv w -> mkCCall (word2FloatLabel w)
+ -- Optional MachOps
+ -- These are enabled/disabled by backend flags: GHC.StgToCmm.Config
+ MO_S_Mul2 _w -> unsupported mop
+ MO_S_QuotRem _w -> unsupported mop
+ MO_U_QuotRem _w -> unsupported mop
+ MO_U_QuotRem2 _w -> unsupported mop
+ MO_Add2 _w -> unsupported mop
+ MO_AddWordC _w -> unsupported mop
+ MO_SubWordC _w -> unsupported mop
+ MO_AddIntC _w -> unsupported mop
+ MO_SubIntC _w -> unsupported mop
+ MO_U_Mul2 _w -> unsupported mop
+ -- Memory Ordering
+ -- The related C functions are:
+ -- #include <stdatomic.h>
+ -- atomic_thread_fence(memory_order_acquire);
+ -- atomic_thread_fence(memory_order_release);
+ -- atomic_thread_fence(memory_order_seq_cst);
+ MO_AcquireFence -> pure (unitOL (FENCE FenceRead FenceReadWrite))
+ MO_ReleaseFence -> pure (unitOL (FENCE FenceReadWrite FenceWrite))
+ MO_SeqCstFence -> pure (unitOL (FENCE FenceReadWrite FenceReadWrite))
+ MO_Touch -> pure nilOL -- Keep variables live (when using interior pointers)
+ -- Prefetch
+ MO_Prefetch_Data _n -> pure nilOL -- Prefetch hint.
+
+ -- Memory copy/set/move/cmp, with alignment for optimization
+ MO_Memcpy _align -> mkCCall "memcpy"
+ MO_Memset _align -> mkCCall "memset"
+ MO_Memmove _align -> mkCCall "memmove"
+ MO_Memcmp _align -> mkCCall "memcmp"
+ MO_SuspendThread -> mkCCall "suspendThread"
+ MO_ResumeThread -> mkCCall "resumeThread"
+ MO_PopCnt w -> mkCCall (popCntLabel w)
+ MO_Pdep w -> mkCCall (pdepLabel w)
+ MO_Pext w -> mkCCall (pextLabel w)
+ MO_Clz w -> mkCCall (clzLabel w)
+ MO_Ctz w -> mkCCall (ctzLabel w)
+ MO_BSwap w -> mkCCall (bSwapLabel w)
+ MO_BRev w -> mkCCall (bRevLabel w)
+ -- Atomic read-modify-write.
+ mo@(MO_AtomicRead w ord)
+ | [p_reg] <- arg_regs,
+ [dst_reg] <- dest_regs -> do
+ (p, _fmt_p, code_p) <- getSomeReg p_reg
+ platform <- getPlatform
+ -- Analog to the related MachOps (above)
+ -- The related C functions are:
+ -- #include <stdatomic.h>
+ -- __atomic_load_n(&a, __ATOMIC_ACQUIRE);
+ -- __atomic_load_n(&a, __ATOMIC_SEQ_CST);
+ let instrs = case ord of
+ MemOrderRelaxed -> unitOL $ ann moDescr (LDR (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p))
+ MemOrderAcquire ->
+ toOL
+ [ ann moDescr (LDR (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)),
+ FENCE FenceRead FenceReadWrite
+ ]
+ MemOrderSeqCst ->
+ toOL
+ [ ann moDescr (FENCE FenceReadWrite FenceReadWrite),
+ LDR (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p),
+ FENCE FenceRead FenceReadWrite
+ ]
+ MemOrderRelease -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo
+ dst = getRegisterReg platform (CmmLocal dst_reg)
+ moDescr = (text . show) mo
+ code = code_p `appOL` instrs
+ return code
+ | otherwise -> panic "mal-formed AtomicRead"
+ mo@(MO_AtomicWrite w ord)
+ | [p_reg, val_reg] <- arg_regs -> do
+ (p, _fmt_p, code_p) <- getSomeReg p_reg
+ (val, fmt_val, code_val) <- getSomeReg val_reg
+ -- Analog to the related MachOps (above)
+ -- The related C functions are:
+ -- #include <stdatomic.h>
+ -- __atomic_store_n(&a, 23, __ATOMIC_SEQ_CST);
+ -- __atomic_store_n(&a, 23, __ATOMIC_RELEASE);
+ let instrs = case ord of
+ MemOrderRelaxed -> unitOL $ ann moDescr (STR fmt_val (OpReg w val) (OpAddr $ AddrReg p))
+ MemOrderSeqCst ->
+ toOL
+ [ ann moDescr (FENCE FenceReadWrite FenceWrite),
+ STR fmt_val (OpReg w val) (OpAddr $ AddrReg p),
+ FENCE FenceReadWrite FenceReadWrite
+ ]
+ MemOrderRelease ->
+ toOL
+ [ ann moDescr (FENCE FenceReadWrite FenceWrite),
+ STR fmt_val (OpReg w val) (OpAddr $ AddrReg p)
+ ]
+ MemOrderAcquire -> panic $ "Unexpected MemOrderAcquire on an AtomicWrite" ++ show mo
+ moDescr = (text . show) mo
+ code =
+ code_p
+ `appOL` code_val
+ `appOL` instrs
+ pure code
+ | otherwise -> panic "mal-formed AtomicWrite"
+ MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)
+ MO_Cmpxchg w -> mkCCall (cmpxchgLabel w)
+ -- -- Should be an AtomicRMW variant eventually.
+ -- -- Sequential consistent.
+ -- TODO: this should be implemented properly!
+ MO_Xchg w -> mkCCall (xchgLabel w)
+ where
+ unsupported :: (Show a) => a -> b
+ unsupported mop =
+ panic
+ ( "outOfLineCmmOp: "
+ ++ show mop
+ ++ " not supported here"
+ )
+ mkCCall :: FastString -> NatM InstrBlock
+ mkCCall name = do
+ config <- getConfig
+ target <-
+ cmmMakeDynamicReference config CallReference
+ $ mkForeignLabel name Nothing ForeignLabelInThisPackage IsFunction
+ let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn
+ genCCall (ForeignTarget target cconv) dest_regs arg_regs
+
+ unaryFloatOp w op arg_reg dest_reg = do
+ platform <- getPlatform
+ (reg_fx, _format_x, code_fx) <- getFloatReg arg_reg
+ let dst = getRegisterReg platform (CmmLocal dest_reg)
+ let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx)
+ pure code
+
+{- Note [RISCV64 far jumps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+RISCV64 conditional jump instructions can only encode an offset of +/-4KiB
+(12bits) which is usually enough but can be exceeded in edge cases. In these
+cases we will replace:
+
+ b.cond <cond> foo
+
+with the sequence:
+
+ b.cond <cond> <lbl_true>
+ b <lbl_false>
+ <lbl_true>:
+ la reg foo
+ b reg
+ <lbl_false>:
+
+and
+
+ b foo
+
+with the sequence:
+
+ la reg foo
+ b reg
+
+Compared to AArch64 the target label is loaded to a register, because
+unconditional jump instructions can only address +/-1MiB. The LA
+pseudo-instruction will be replaced by up to two real instructions, ensuring
+correct addressing.
+
+One could surely find more efficient replacements, taking PC-relative addressing
+into account. This could be a future improvement. (As far branches are pretty
+rare, one might question and measure the value of such improvement.)
+
+RISCV has many pseudo-instructions which emit more than one real instructions.
+Thus, we count the real instructions after the Assembler has seen them.
+
+We make some simplifications in the name of performance which can result in
+overestimating jump <-> label offsets:
+
+\* To avoid having to recalculate the label offsets once we replaced a jump we simply
+ assume all label jumps will be expanded to a three instruction far jump sequence.
+\* For labels associated with a info table we assume the info table is 64byte large.
+ Most info tables are smaller than that but it means we don't have to distinguish
+ between multiple types of info tables.
+
+In terms of implementation we walk the instruction stream at least once calculating
+label offsets, and if we determine during this that the functions body is big enough
+to potentially contain out of range jumps we walk the instructions a second time, replacing
+out of range jumps with the sequence of instructions described above.
+
+-}
+
+-- | A conditional jump to a far target
+--
+-- By loading the far target into a register for the jump, we can address the
+-- whole memory range.
+genCondFarJump :: (MonadUnique m) => Cond -> Operand -> Operand -> BlockId -> m InstrBlock
+genCondFarJump cond op1 op2 far_target = do
+ skip_lbl_id <- newBlockId
+ jmp_lbl_id <- newBlockId
+
+ -- TODO: We can improve this by inverting the condition
+ -- but it's not quite trivial since we don't know if we
+ -- need to consider float orderings.
+ -- So we take the hit of the additional jump in the false
+ -- case for now.
+ return
+ $ toOL
+ [ ann (text "Conditional far jump to: " <> ppr far_target)
+ $ BCOND cond op1 op2 (TBlock jmp_lbl_id),
+ B (TBlock skip_lbl_id),
+ NEWBLOCK jmp_lbl_id,
+ LDR II64 (OpReg W64 tmpReg) (OpImm (ImmCLbl (blockLbl far_target))),
+ B (TReg tmpReg),
+ NEWBLOCK skip_lbl_id
+ ]
+
+-- | An unconditional jump to a far target
+--
+-- By loading the far target into a register for the jump, we can address the
+-- whole memory range.
+genFarJump :: (MonadUnique m) => BlockId -> m InstrBlock
+genFarJump far_target =
+ return
+ $ toOL
+ [ ann (text "Unconditional far jump to: " <> ppr far_target)
+ $ LDR II64 (OpReg W64 tmpReg) (OpImm (ImmCLbl (blockLbl far_target))),
+ B (TReg tmpReg)
+ ]
+
+-- See Note [RISCV64 far jumps]
+data BlockInRange = InRange | NotInRange BlockId
+
+-- See Note [RISCV64 far jumps]
+makeFarBranches ::
+ Platform ->
+ LabelMap RawCmmStatics ->
+ [NatBasicBlock Instr] ->
+ UniqSM [NatBasicBlock Instr]
+makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do
+ -- All offsets/positions are counted in multiples of 4 bytes (the size of RISCV64 instructions)
+ -- That is an offset of 1 represents a 4-byte/one instruction offset.
+ let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks
+ if func_size < max_jump_dist
+ then pure basic_blocks
+ else do
+ (_, blocks) <- mapAccumLM (replace_blk lblMap) 0 basic_blocks
+ pure $ concat blocks
+ where
+ -- pprTrace "lblMap" (ppr lblMap) $ basic_blocks
+
+ -- 2^11, 12 bit immediate with one bit is reserved for the sign
+ max_jump_dist = 2 ^ (11 :: Int) - 1 :: Int
+ -- Currently all inline info tables fit into 64 bytes.
+ max_info_size = 16 :: Int
+ long_bc_jump_size = 5 :: Int
+ long_b_jump_size = 2 :: Int
+
+ -- Replace out of range conditional jumps with unconditional jumps.
+ replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqSM (Int, [GenBasicBlock Instr])
+ replace_blk !m !pos (BasicBlock lbl instrs) = do
+ -- Account for a potential info table before the label.
+ let !block_pos = pos + infoTblSize_maybe lbl
+ (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs
+ let instrs'' = concat instrs'
+ -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary.
+ let (top, split_blocks, no_data) = foldr mkBlocks ([], [], []) instrs''
+ -- There should be no data in the instruction stream at this point
+ massert (null no_data)
+
+ let final_blocks = BasicBlock lbl top : split_blocks
+ pure (pos', final_blocks)
+
+ replace_jump :: LabelMap Int -> Int -> Instr -> UniqSM (Int, [Instr])
+ replace_jump !m !pos instr = do
+ case instr of
+ ANN ann instr -> do
+ (idx, instr' : instrs') <- replace_jump m pos instr
+ pure (idx, ANN ann instr' : instrs')
+ BCOND cond op1 op2 t ->
+ case target_in_range m t pos of
+ InRange -> pure (pos + instr_size instr, [instr])
+ NotInRange far_target -> do
+ jmp_code <- genCondFarJump cond op1 op2 far_target
+ pure (pos + instr_size instr, fromOL jmp_code)
+ B t ->
+ case target_in_range m t pos of
+ InRange -> pure (pos + instr_size instr, [instr])
+ NotInRange far_target -> do
+ jmp_code <- genFarJump far_target
+ pure (pos + instr_size instr, fromOL jmp_code)
+ _ -> pure (pos + instr_size instr, [instr])
+
+ target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange
+ target_in_range m target src =
+ case target of
+ (TReg {}) -> InRange
+ (TBlock bid) -> block_in_range m src bid
+
+ block_in_range :: LabelMap Int -> Int -> BlockId -> BlockInRange
+ block_in_range m src_pos dest_lbl =
+ case mapLookup dest_lbl m of
+ Nothing ->
+ pprTrace "not in range" (ppr dest_lbl)
+ $ NotInRange dest_lbl
+ Just dest_pos ->
+ if abs (dest_pos - src_pos) < max_jump_dist
+ then InRange
+ else NotInRange dest_lbl
+
+ calc_lbl_positions :: (Int, LabelMap Int) -> GenBasicBlock Instr -> (Int, LabelMap Int)
+ calc_lbl_positions (pos, m) (BasicBlock lbl instrs) =
+ let !pos' = pos + infoTblSize_maybe lbl
+ in foldl' instr_pos (pos', mapInsert lbl pos' m) instrs
+
+ instr_pos :: (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int)
+ instr_pos (pos, m) instr = (pos + instr_size instr, m)
+
+ infoTblSize_maybe bid =
+ case mapLookup bid statics of
+ Nothing -> 0 :: Int
+ Just _info_static -> max_info_size
+
+ instr_size :: Instr -> Int
+ instr_size i = case i of
+ COMMENT {} -> 0
+ MULTILINE_COMMENT {} -> 0
+ ANN _ instr -> instr_size instr
+ LOCATION {} -> 0
+ DELTA {} -> 0
+ -- At this point there should be no NEWBLOCK in the instruction stream (pos, mapInsert bid pos m)
+ NEWBLOCK {} -> panic "mkFarBranched - Unexpected"
+ LDATA {} -> panic "mkFarBranched - Unexpected"
+ PUSH_STACK_FRAME -> 4
+ POP_STACK_FRAME -> 4
+ ADD {} -> 1
+ MUL {} -> 1
+ MULH {} -> 1
+ NEG {} -> 1
+ DIV {} -> 1
+ REM {} -> 1
+ REMU {} -> 1
+ SUB {} -> 1
+ DIVU {} -> 1
+ AND {} -> 1
+ OR {} -> 1
+ SRA {} -> 1
+ XOR {} -> 1
+ SLL {} -> 1
+ SRL {} -> 1
+ MOV {} -> 2
+ ORI {} -> 1
+ XORI {} -> 1
+ CSET {} -> 2
+ STR {} -> 1
+ LDR {} -> 3
+ LDRU {} -> 1
+ FENCE {} -> 1
+ FCVT {} -> 1
+ FABS {} -> 1
+ FMA {} -> 1
+ -- estimate the subsituted size for jumps to lables
+ -- jumps to registers have size 1
+ BCOND {} -> long_bc_jump_size
+ B (TBlock _) -> long_b_jump_size
+ B (TReg _) -> 1
+ BL _ _ -> 1
+ J_TBL {} -> 1
Index: ghc-9.10.1/compiler/GHC/CmmToAsm/RV64/Cond.hs
===================================================================
--- /dev/null
+++ ghc-9.10.1/compiler/GHC/CmmToAsm/RV64/Cond.hs
@@ -0,0 +1,42 @@
+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)
Index: ghc-9.10.1/compiler/GHC/CmmToAsm/RV64/Instr.hs
===================================================================
--- /dev/null
+++ ghc-9.10.1/compiler/GHC/CmmToAsm/RV64/Instr.hs
@@ -0,0 +1,823 @@
+-- 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
+
+-- | 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 would 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 (TMP) for this purpose (and other, unrelated
+-- intermediate operations.) See Note [The made-up RISCV64 TMP (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 ->
+ [ movImmToTmp imm,
+ addSpToTmp,
+ mkStrTmp
+ ]
+ 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)))
+ movImmToTmp imm =
+ ANN (text "Spill: TMP <- " <> int imm)
+ $ MOV tmp (OpImm (ImmInt imm))
+ addSpToTmp =
+ ANN (text "Spill: TMP <- SP + TMP ")
+ $ ADD tmp tmp sp
+ mkStrTmp =
+ ANN (text "Spill@" <> int (off - delta))
+ $ STR fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg))
+
+ 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 ->
+ [ movImmToTmp imm,
+ addSpToTmp,
+ mkLdrTmp
+ ]
+ 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)))
+ movImmToTmp imm =
+ ANN (text "Reload: TMP <- " <> int imm)
+ $ MOV tmp (OpImm (ImmInt imm))
+ addSpToTmp =
+ ANN (text "Reload: TMP <- SP + TMP ")
+ $ ADD tmp tmp sp
+ mkLdrTmp =
+ ANN (text "Reload@" <> int (off - delta))
+ $ LDR fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg))
+
+ 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 tmp (OpImm (ImmInt n))),
+ ADD sp sp tmp
+ ]
+ 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, tmp :: Operand
+zero = operandFromReg zeroReg
+ra = operandFromReg raReg
+sp = operandFromReg spMachReg
+gp = operandFromRegNo 3
+tp = operandFromRegNo 4
+fp = operandFromRegNo 8
+tmp = operandFromReg tmpReg
+
+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
Index: ghc-9.10.1/compiler/GHC/CmmToAsm/RV64/Ppr.hs
===================================================================
--- /dev/null
+++ ghc-9.10.1/compiler/GHC/CmmToAsm/RV64/Ppr.hs
@@ -0,0 +1,715 @@
+{-# 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 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
Index: ghc-9.10.1/compiler/GHC/CmmToAsm/RV64/RegInfo.hs
===================================================================
--- /dev/null
+++ ghc-9.10.1/compiler/GHC/CmmToAsm/RV64/RegInfo.hs
@@ -0,0 +1,41 @@
+-- | 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
Index: ghc-9.10.1/compiler/GHC/CmmToAsm/RV64/Regs.hs
===================================================================
--- /dev/null
+++ ghc-9.10.1/compiler/GHC/CmmToAsm/RV64/Regs.hs
@@ -0,0 +1,230 @@
+module GHC.CmmToAsm.RV64.Regs where
+
+import GHC.Cmm
+import GHC.Cmm.CLabel (CLabel)
+import GHC.CmmToAsm.Format
+import GHC.Data.FastString
+import GHC.Platform
+import GHC.Platform.Reg
+import GHC.Platform.Reg.Class
+import GHC.Platform.Regs
+import GHC.Prelude
+import GHC.Types.Unique
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+
+-- * Registers
+
+-- | First integer register number. @zero@ register.
+x0RegNo :: RegNo
+x0RegNo = 0
+
+-- | return address register
+x1RegNo, raRegNo :: RegNo
+x1RegNo = 1
+raRegNo = x1RegNo
+
+x5RegNo, t0RegNo :: RegNo
+x5RegNo = 5
+t0RegNo = x5RegNo
+
+x7RegNo, t2RegNo :: RegNo
+x7RegNo = 7
+t2RegNo = x7RegNo
+
+x28RegNo, t3RegNo :: RegNo
+x28RegNo = 28
+t3RegNo = x28RegNo
+
+-- | Last integer register number. Used as TMP (IP) register.
+x31RegNo, t6RegNo, tmpRegNo :: RegNo
+x31RegNo = 31
+t6RegNo = x31RegNo
+tmpRegNo = x31RegNo
+
+-- | First floating point register.
+d0RegNo, ft0RegNo :: RegNo
+d0RegNo = 32
+ft0RegNo = d0RegNo
+
+d7RegNo, ft7RegNo :: RegNo
+d7RegNo = 39
+ft7RegNo = d7RegNo
+
+-- | Last floating point register.
+d31RegNo :: RegNo
+d31RegNo = 63
+
+a0RegNo, x10RegNo :: RegNo
+x10RegNo = 10
+a0RegNo = x10RegNo
+
+a7RegNo, x17RegNo :: RegNo
+x17RegNo = 17
+a7RegNo = x17RegNo
+
+fa0RegNo, d10RegNo :: RegNo
+d10RegNo = 42
+fa0RegNo = d10RegNo
+
+fa7RegNo, d17RegNo :: RegNo
+d17RegNo = 49
+fa7RegNo = d17RegNo
+
+-- Note [The made-up RISCV64 TMP (IP) register]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- RISCV64 has no inter-procedural register in its ABI. However, we need one to
+-- make register spills/loads to/from high number slots. I.e. slot numbers that
+-- do not fit in a 12bit integer which is used as immediate in the arithmetic
+-- operations. Thus, we're marking one additional register (x31) as permanently
+-- non-free and call it TMP.
+--
+-- TMP can be used as temporary register in all operations. Just be aware that
+-- it may be clobbered as soon as you loose direct control over it (i.e. using
+-- TMP by-passes the register allocation/spilling mechanisms.) It should be fine
+-- to use it as temporary register in a MachOp translation as long as you don't
+-- rely on its value beyond this limited scope.
+--
+-- X31 is a caller-saved register. I.e. there are no guarantees about what the
+-- callee does with it. That's exactly what we want here.
+
+zeroReg, raReg, spMachReg, tmpReg :: Reg
+zeroReg = regSingle x0RegNo
+raReg = regSingle 1
+
+-- | Not to be confused with the `CmmReg` `spReg`
+spMachReg = regSingle 2
+
+tmpReg = regSingle tmpRegNo
+
+-- | All machine register numbers.
+allMachRegNos :: [RegNo]
+allMachRegNos = intRegs ++ fpRegs
+ where
+ intRegs = [x0RegNo .. x31RegNo]
+ fpRegs = [d0RegNo .. d31RegNo]
+
+-- | Registers available to the register allocator.
+--
+-- These are all registers minus those with a fixed role in RISCV ABI (zero, lr,
+-- sp, gp, tp, fp, tmp) and GHC RTS (Base, Sp, Hp, HpLim, R1..R8, F1..F6,
+-- D1..D6.)
+allocatableRegs :: Platform -> [RealReg]
+allocatableRegs platform =
+ let isFree = freeReg platform
+ in map RealRegSingle $ filter isFree allMachRegNos
+
+-- | Integer argument registers according to the calling convention
+allGpArgRegs :: [Reg]
+allGpArgRegs = map regSingle [a0RegNo .. a7RegNo]
+
+-- | Floating point argument registers according to the calling convention
+allFpArgRegs :: [Reg]
+allFpArgRegs = map regSingle [fa0RegNo .. fa7RegNo]
+
+-- * Addressing modes
+
+-- | Addressing modes
+data AddrMode
+ = -- | A register plus some immediate integer, e.g. @8(sp)@ or @-16(sp)@. The
+ -- offset needs to fit into 12bits.
+ AddrRegImm Reg Imm
+ | -- | A register
+ AddrReg Reg
+ deriving (Eq, Show)
+
+-- * Immediates
+
+data Imm
+ = ImmInt Int
+ | ImmInteger Integer -- Sigh.
+ | ImmCLbl CLabel -- AbstractC Label (with baggage)
+ | ImmLit FastString
+ | ImmIndex CLabel Int
+ | ImmFloat Rational
+ | ImmDouble Rational
+ | ImmConstantSum Imm Imm
+ | ImmConstantDiff Imm Imm
+ deriving (Eq, Show)
+
+-- | Map `CmmLit` to `Imm`
+--
+-- N.B. this is a partial function, because not all `CmmLit`s have an immediate
+-- representation.
+litToImm :: CmmLit -> Imm
+litToImm (CmmInt i w) = ImmInteger (narrowS w i)
+-- narrow to the width: a CmmInt might be out of
+-- range, but we assume that ImmInteger only contains
+-- in-range values. A signed value should be fine here.
+litToImm (CmmFloat f W32) = ImmFloat f
+litToImm (CmmFloat f W64) = ImmDouble f
+litToImm (CmmLabel l) = ImmCLbl l
+litToImm (CmmLabelOff l off) = ImmIndex l off
+litToImm (CmmLabelDiffOff l1 l2 off _) =
+ ImmConstantSum
+ (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
+ (ImmInt off)
+litToImm l = panic $ "RV64.Regs.litToImm: no match for " ++ show l
+
+-- == To satisfy GHC.CmmToAsm.Reg.Target =======================================
+
+-- squeese functions for the graph allocator -----------------------------------
+
+-- | regSqueeze_class reg
+-- Calculate the maximum number of register colors that could be
+-- denied to a node of this class due to having this reg
+-- as a neighbour.
+{-# INLINE virtualRegSqueeze #-}
+virtualRegSqueeze :: RegClass -> VirtualReg -> Int
+virtualRegSqueeze cls vr =
+ case cls of
+ RcInteger ->
+ case vr of
+ VirtualRegI {} -> 1
+ VirtualRegHi {} -> 1
+ _other -> 0
+ RcDouble ->
+ case vr of
+ VirtualRegD {} -> 1
+ VirtualRegF {} -> 0
+ _other -> 0
+ _other -> 0
+
+{-# INLINE realRegSqueeze #-}
+realRegSqueeze :: RegClass -> RealReg -> Int
+realRegSqueeze cls rr =
+ case cls of
+ RcInteger ->
+ case rr of
+ RealRegSingle regNo
+ | regNo < d0RegNo -> 1
+ | otherwise -> 0
+ RcDouble ->
+ case rr of
+ RealRegSingle regNo
+ | regNo < d0RegNo -> 0
+ | otherwise -> 1
+ _other -> 0
+
+mkVirtualReg :: Unique -> Format -> VirtualReg
+mkVirtualReg u format
+ | not (isFloatFormat format) = VirtualRegI u
+ | otherwise =
+ case format of
+ FF32 -> VirtualRegD u
+ FF64 -> VirtualRegD u
+ _ -> panic "RV64.mkVirtualReg"
+
+{-# INLINE classOfRealReg #-}
+classOfRealReg :: RealReg -> RegClass
+classOfRealReg (RealRegSingle i)
+ | i < d0RegNo = RcInteger
+ | otherwise = RcDouble
+
+regDotColor :: RealReg -> SDoc
+regDotColor reg =
+ case classOfRealReg reg of
+ RcInteger -> text "blue"
+ RcFloat -> text "red"
+ RcDouble -> text "green"
Index: ghc-9.10.1/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs
===================================================================
--- ghc-9.10.1.orig/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs
+++ ghc-9.10.1/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs
@@ -119,7 +119,7 @@ trivColorable platform virtualRegSqueeze
ArchMipseb -> panic "trivColorable ArchMipseb"
ArchMipsel -> panic "trivColorable ArchMipsel"
ArchS390X -> panic "trivColorable ArchS390X"
- ArchRISCV64 -> panic "trivColorable ArchRISCV64"
+ ArchRISCV64 -> 14
ArchLoongArch64->panic "trivColorable ArchLoongArch64"
ArchJavaScript-> panic "trivColorable ArchJavaScript"
ArchWasm32 -> panic "trivColorable ArchWasm32"
@@ -154,7 +154,7 @@ trivColorable platform virtualRegSqueeze
ArchMipseb -> panic "trivColorable ArchMipseb"
ArchMipsel -> panic "trivColorable ArchMipsel"
ArchS390X -> panic "trivColorable ArchS390X"
- ArchRISCV64 -> panic "trivColorable ArchRISCV64"
+ ArchRISCV64 -> 0
ArchLoongArch64->panic "trivColorable ArchLoongArch64"
ArchJavaScript-> panic "trivColorable ArchJavaScript"
ArchWasm32 -> panic "trivColorable ArchWasm32"
@@ -188,7 +188,7 @@ trivColorable platform virtualRegSqueeze
ArchMipseb -> panic "trivColorable ArchMipseb"
ArchMipsel -> panic "trivColorable ArchMipsel"
ArchS390X -> panic "trivColorable ArchS390X"
- ArchRISCV64 -> panic "trivColorable ArchRISCV64"
+ ArchRISCV64 -> 20
ArchLoongArch64->panic "trivColorable ArchLoongArch64"
ArchJavaScript-> panic "trivColorable ArchJavaScript"
ArchWasm32 -> panic "trivColorable ArchWasm32"
Index: ghc-9.10.1/compiler/GHC/CmmToAsm/Reg/Linear.hs
===================================================================
--- ghc-9.10.1.orig/compiler/GHC/CmmToAsm/Reg/Linear.hs
+++ ghc-9.10.1/compiler/GHC/CmmToAsm/Reg/Linear.hs
@@ -112,6 +112,7 @@ import qualified GHC.CmmToAsm.Reg.Linear
import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86
import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64
import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64
+import qualified GHC.CmmToAsm.Reg.Linear.RV64 as RV64
import GHC.CmmToAsm.Reg.Target
import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Reg.Utils
@@ -221,7 +222,7 @@ linearRegAlloc config entry_ids block_li
ArchAlpha -> panic "linearRegAlloc ArchAlpha"
ArchMipseb -> panic "linearRegAlloc ArchMipseb"
ArchMipsel -> panic "linearRegAlloc ArchMipsel"
- ArchRISCV64 -> panic "linearRegAlloc ArchRISCV64"
+ ArchRISCV64 -> go (frInitFreeRegs platform :: RV64.FreeRegs)
ArchLoongArch64-> panic "linearRegAlloc ArchLoongArch64"
ArchJavaScript -> panic "linearRegAlloc ArchJavaScript"
ArchWasm32 -> panic "linearRegAlloc ArchWasm32"
Index: ghc-9.10.1/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs
===================================================================
--- ghc-9.10.1.orig/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs
+++ ghc-9.10.1/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs
@@ -29,10 +29,12 @@ import qualified GHC.CmmToAsm.Reg.Linear
import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86
import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64
import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64
+import qualified GHC.CmmToAsm.Reg.Linear.RV64 as RV64
import qualified GHC.CmmToAsm.PPC.Instr as PPC.Instr
import qualified GHC.CmmToAsm.X86.Instr as X86.Instr
import qualified GHC.CmmToAsm.AArch64.Instr as AArch64.Instr
+import qualified GHC.CmmToAsm.RV64.Instr as RV64.Instr
class Show freeRegs => FR freeRegs where
frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs
@@ -64,6 +66,12 @@ instance FR AArch64.FreeRegs where
frInitFreeRegs = AArch64.initFreeRegs
frReleaseReg = \_ -> AArch64.releaseReg
+instance FR RV64.FreeRegs where
+ frAllocateReg = const RV64.allocateReg
+ frGetFreeRegs = const RV64.getFreeRegs
+ frInitFreeRegs = RV64.initFreeRegs
+ frReleaseReg = const RV64.releaseReg
+
maxSpillSlots :: NCGConfig -> Int
maxSpillSlots config = case platformArch (ncgPlatform config) of
ArchX86 -> X86.Instr.maxSpillSlots config
@@ -76,7 +84,7 @@ maxSpillSlots config = case platformArch
ArchAlpha -> panic "maxSpillSlots ArchAlpha"
ArchMipseb -> panic "maxSpillSlots ArchMipseb"
ArchMipsel -> panic "maxSpillSlots ArchMipsel"
- ArchRISCV64 -> panic "maxSpillSlots ArchRISCV64"
+ ArchRISCV64 -> RV64.Instr.maxSpillSlots config
ArchLoongArch64->panic "maxSpillSlots ArchLoongArch64"
ArchJavaScript-> panic "maxSpillSlots ArchJavaScript"
ArchWasm32 -> panic "maxSpillSlots ArchWasm32"
Index: ghc-9.10.1/compiler/GHC/CmmToAsm/Reg/Linear/RV64.hs
===================================================================
--- /dev/null
+++ ghc-9.10.1/compiler/GHC/CmmToAsm/Reg/Linear/RV64.hs
@@ -0,0 +1,96 @@
+-- | Functions to implement the @FR@ (as in "free regs") type class.
+--
+-- For LLVM GHC calling convention (used registers), see
+-- https://github.com/llvm/llvm-project/blob/6ab900f8746e7d8e24afafb5886a40801f6799f4/llvm/lib/Target/RISCV/RISCVISelLowering.cpp#L13638-L13685
+module GHC.CmmToAsm.Reg.Linear.RV64
+ ( allocateReg,
+ getFreeRegs,
+ initFreeRegs,
+ releaseReg,
+ FreeRegs (..),
+ )
+where
+
+import Data.Word
+import GHC.CmmToAsm.RV64.Regs
+import GHC.Platform
+import GHC.Platform.Reg
+import GHC.Platform.Reg.Class
+import GHC.Prelude
+import GHC.Stack
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+
+-- | Bitmaps to indicate which registers are free (currently unused)
+--
+-- The bit index represents the `RegNo`, in case of floating point registers
+-- with an offset of 32. The register is free when the bit is set.
+data FreeRegs
+ = FreeRegs
+ -- | integer/general purpose registers (`RcInteger`)
+ !Word32
+ -- | floating point registers (`RcDouble`)
+ !Word32
+
+instance Show FreeRegs where
+ show (FreeRegs g f) = "FreeRegs 0b" ++ showBits g ++ " 0b" ++ showBits f
+
+-- | Show bits as a `String` of @1@s and @0@s
+showBits :: Word32 -> String
+showBits w = map (\i -> if testBit w i then '1' else '0') [0 .. 31]
+
+instance Outputable FreeRegs where
+ ppr (FreeRegs g f) =
+ text " "
+ <+> foldr (\i x -> pad_int i <+> x) (text "") [0 .. 31]
+ $$ text "GPR"
+ <+> foldr (\i x -> show_bit g i <+> x) (text "") [0 .. 31]
+ $$ text "FPR"
+ <+> foldr (\i x -> show_bit f i <+> x) (text "") [0 .. 31]
+ where
+ pad_int i | i < 10 = char ' ' <> int i
+ pad_int i = int i
+ -- remember bit = 1 means it's available.
+ show_bit bits bit | testBit bits bit = text " "
+ show_bit _ _ = text " x"
+
+-- | Set bits of all allocatable registers to 1
+initFreeRegs :: Platform -> FreeRegs
+initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)
+ where
+ noFreeRegs :: FreeRegs
+ noFreeRegs = FreeRegs 0 0
+
+-- | Get all free `RealReg`s (i.e. those where the corresponding bit is 1)
+getFreeRegs :: RegClass -> FreeRegs -> [RealReg]
+getFreeRegs cls (FreeRegs g f)
+ | RcFloat <- cls = [] -- For now we only support double and integer registers, floats will need to be promoted.
+ | RcDouble <- cls = go 32 f allocatableDoubleRegs
+ | RcInteger <- cls = go 0 g allocatableIntRegs
+ where
+ go _ _ [] = []
+ go off x (i : is)
+ | testBit x i = RealRegSingle (off + i) : (go off x $! is)
+ | otherwise = go off x $! is
+ -- The lists of allocatable registers are manually crafted: Register
+ -- allocation is pretty hot code. We don't want to iterate and map like
+ -- `initFreeRegs` all the time! (The register mappings aren't supposed to
+ -- change often.)
+ allocatableIntRegs = [5 .. 7] ++ [10 .. 17] ++ [28 .. 30]
+ allocatableDoubleRegs = [0 .. 7] ++ [10 .. 17] ++ [28 .. 31]
+
+-- | Set corresponding register bit to 0
+allocateReg :: (HasCallStack) => RealReg -> FreeRegs -> FreeRegs
+allocateReg (RealRegSingle r) (FreeRegs g f)
+ | r > 31 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32))
+ | r < 32 && testBit g r = FreeRegs (clearBit g r) f
+ | r > 31 = panic $ "Linear.RV64.allocReg: double allocation of float reg v" ++ show (r - 32) ++ "; " ++ showBits f
+ | otherwise = pprPanic "Linear.RV64.allocReg" $ text ("double allocation of gp reg x" ++ show r ++ "; " ++ showBits g)
+
+-- | Set corresponding register bit to 1
+releaseReg :: (HasCallStack) => RealReg -> FreeRegs -> FreeRegs
+releaseReg (RealRegSingle r) (FreeRegs g f)
+ | r > 31 && testBit f (r - 32) = pprPanic "Linear.RV64.releaseReg" (text "can't release non-allocated reg v" <> int (r - 32))
+ | r < 32 && testBit g r = pprPanic "Linear.RV64.releaseReg" (text "can't release non-allocated reg x" <> int r)
+ | r > 31 = FreeRegs g (setBit f (r - 32))
+ | otherwise = FreeRegs (setBit g r) f
Index: ghc-9.10.1/compiler/GHC/CmmToAsm/Reg/Target.hs
===================================================================
--- ghc-9.10.1.orig/compiler/GHC/CmmToAsm/Reg/Target.hs
+++ ghc-9.10.1/compiler/GHC/CmmToAsm/Reg/Target.hs
@@ -34,7 +34,7 @@ import qualified GHC.CmmToAsm.X86.Regs
import qualified GHC.CmmToAsm.X86.RegInfo as X86
import qualified GHC.CmmToAsm.PPC.Regs as PPC
import qualified GHC.CmmToAsm.AArch64.Regs as AArch64
-
+import qualified GHC.CmmToAsm.RV64.Regs as RV64
targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> Int
targetVirtualRegSqueeze platform
@@ -49,7 +49,7 @@ targetVirtualRegSqueeze platform
ArchAlpha -> panic "targetVirtualRegSqueeze ArchAlpha"
ArchMipseb -> panic "targetVirtualRegSqueeze ArchMipseb"
ArchMipsel -> panic "targetVirtualRegSqueeze ArchMipsel"
- ArchRISCV64 -> panic "targetVirtualRegSqueeze ArchRISCV64"
+ ArchRISCV64 -> RV64.virtualRegSqueeze
ArchLoongArch64->panic "targetVirtualRegSqueeze ArchLoongArch64"
ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript"
ArchWasm32 -> panic "targetVirtualRegSqueeze ArchWasm32"
@@ -69,7 +69,7 @@ targetRealRegSqueeze platform
ArchAlpha -> panic "targetRealRegSqueeze ArchAlpha"
ArchMipseb -> panic "targetRealRegSqueeze ArchMipseb"
ArchMipsel -> panic "targetRealRegSqueeze ArchMipsel"
- ArchRISCV64 -> panic "targetRealRegSqueeze ArchRISCV64"
+ ArchRISCV64 -> RV64.realRegSqueeze
ArchLoongArch64->panic "targetRealRegSqueeze ArchLoongArch64"
ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript"
ArchWasm32 -> panic "targetRealRegSqueeze ArchWasm32"
@@ -88,7 +88,7 @@ targetClassOfRealReg platform
ArchAlpha -> panic "targetClassOfRealReg ArchAlpha"
ArchMipseb -> panic "targetClassOfRealReg ArchMipseb"
ArchMipsel -> panic "targetClassOfRealReg ArchMipsel"
- ArchRISCV64 -> panic "targetClassOfRealReg ArchRISCV64"
+ ArchRISCV64 -> RV64.classOfRealReg
ArchLoongArch64->panic "targetClassOfRealReg ArchLoongArch64"
ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript"
ArchWasm32 -> panic "targetClassOfRealReg ArchWasm32"
@@ -107,7 +107,7 @@ targetMkVirtualReg platform
ArchAlpha -> panic "targetMkVirtualReg ArchAlpha"
ArchMipseb -> panic "targetMkVirtualReg ArchMipseb"
ArchMipsel -> panic "targetMkVirtualReg ArchMipsel"
- ArchRISCV64 -> panic "targetMkVirtualReg ArchRISCV64"
+ ArchRISCV64 -> RV64.mkVirtualReg
ArchLoongArch64->panic "targetMkVirtualReg ArchLoongArch64"
ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript"
ArchWasm32 -> panic "targetMkVirtualReg ArchWasm32"
@@ -126,7 +126,7 @@ targetRegDotColor platform
ArchAlpha -> panic "targetRegDotColor ArchAlpha"
ArchMipseb -> panic "targetRegDotColor ArchMipseb"
ArchMipsel -> panic "targetRegDotColor ArchMipsel"
- ArchRISCV64 -> panic "targetRegDotColor ArchRISCV64"
+ ArchRISCV64 -> RV64.regDotColor
ArchLoongArch64->panic "targetRegDotColor ArchLoongArch64"
ArchJavaScript-> panic "targetRegDotColor ArchJavaScript"
ArchWasm32 -> panic "targetRegDotColor ArchWasm32"
Index: ghc-9.10.1/compiler/GHC/Driver/Backend.hs
===================================================================
--- ghc-9.10.1.orig/compiler/GHC/Driver/Backend.hs
+++ ghc-9.10.1/compiler/GHC/Driver/Backend.hs
@@ -213,6 +213,7 @@ platformNcgSupported platform = if
ArchPPC_64 {} -> True
ArchAArch64 -> True
ArchWasm32 -> True
+ ArchRISCV64 -> True
_ -> False
-- | Is the platform supported by the JS backend?
Index: ghc-9.10.1/compiler/GHC/Driver/DynFlags.hs
===================================================================
--- ghc-9.10.1.orig/compiler/GHC/Driver/DynFlags.hs
+++ ghc-9.10.1/compiler/GHC/Driver/DynFlags.hs
@@ -1325,6 +1325,7 @@ default_PIC platform =
(OSDarwin, ArchAArch64) -> [Opt_PIC]
(OSLinux, ArchAArch64) -> [Opt_PIC, Opt_ExternalDynamicRefs]
(OSLinux, ArchARM {}) -> [Opt_PIC, Opt_ExternalDynamicRefs]
+ (OSLinux, ArchRISCV64 {}) -> [Opt_PIC, Opt_ExternalDynamicRefs]
(OSOpenBSD, ArchX86_64) -> [Opt_PIC] -- Due to PIE support in
-- OpenBSD since 5.3 release
-- (1 May 2013) we need to
Index: ghc-9.10.1/compiler/GHC/Platform.hs
===================================================================
--- ghc-9.10.1.orig/compiler/GHC/Platform.hs
+++ ghc-9.10.1/compiler/GHC/Platform.hs
@@ -250,7 +250,6 @@ platformHasRTSLinker p = case archOS_arc
ArchPPC_64 ELF_V1 -> False -- powerpc64
ArchPPC_64 ELF_V2 -> False -- powerpc64le
ArchS390X -> False
- ArchRISCV64 -> False
ArchLoongArch64 -> False
ArchJavaScript -> False
ArchWasm32 -> False
Index: ghc-9.10.1/compiler/ghc.cabal.in
===================================================================
--- ghc-9.10.1.orig/compiler/ghc.cabal.in
+++ ghc-9.10.1/compiler/ghc.cabal.in
@@ -290,6 +290,7 @@ Library
GHC.CmmToAsm.Reg.Linear.FreeRegs
GHC.CmmToAsm.Reg.Linear.JoinToTargets
GHC.CmmToAsm.Reg.Linear.PPC
+ GHC.CmmToAsm.Reg.Linear.RV64
GHC.CmmToAsm.Reg.Linear.StackMap
GHC.CmmToAsm.Reg.Linear.State
GHC.CmmToAsm.Reg.Linear.Stats
@@ -298,6 +299,13 @@ Library
GHC.CmmToAsm.Reg.Liveness
GHC.CmmToAsm.Reg.Target
GHC.CmmToAsm.Reg.Utils
+ GHC.CmmToAsm.RV64
+ GHC.CmmToAsm.RV64.CodeGen
+ GHC.CmmToAsm.RV64.Cond
+ GHC.CmmToAsm.RV64.Instr
+ GHC.CmmToAsm.RV64.Ppr
+ GHC.CmmToAsm.RV64.RegInfo
+ GHC.CmmToAsm.RV64.Regs
GHC.CmmToAsm.Types
GHC.CmmToAsm.Utils
GHC.CmmToAsm.X86
Index: ghc-9.10.1/hadrian/bindist/config.mk.in
===================================================================
--- ghc-9.10.1.orig/hadrian/bindist/config.mk.in
+++ ghc-9.10.1/hadrian/bindist/config.mk.in
@@ -152,7 +152,7 @@ GhcWithSMP := $(strip $(if $(filter YESN
# Whether to include GHCi in the compiler. Depends on whether the RTS linker
# has support for this OS/ARCH combination.
OsSupportsGHCi=$(strip $(patsubst $(TargetOS_CPP), YES, $(findstring $(TargetOS_CPP), mingw32 linux solaris2 freebsd dragonfly netbsd openbsd darwin kfreebsdgnu)))
-ArchSupportsGHCi=$(strip $(patsubst $(TargetArch_CPP), YES, $(findstring $(TargetArch_CPP), i386 x86_64 powerpc powerpc64 powerpc64le sparc sparc64 arm aarch64)))
+ArchSupportsGHCi=$(strip $(patsubst $(TargetArch_CPP), YES, $(findstring $(TargetArch_CPP), i386 x86_64 powerpc powerpc64 powerpc64le sparc sparc64 arm aarch64 riscv64)))
ifeq "$(OsSupportsGHCi)$(ArchSupportsGHCi)" "YESYES"
GhcWithInterpreter=YES
Index: ghc-9.10.1/hadrian/src/Settings/Builders/RunTest.hs
===================================================================
--- ghc-9.10.1.orig/hadrian/src/Settings/Builders/RunTest.hs
+++ ghc-9.10.1/hadrian/src/Settings/Builders/RunTest.hs
@@ -118,7 +118,7 @@ inTreeCompilerArgs stg = do
os <- queryHostTarget queryOS
arch <- queryTargetTarget queryArch
- let codegen_arches = ["x86_64", "i386", "powerpc", "powerpc64", "powerpc64le", "aarch64", "wasm32"]
+ let codegen_arches = ["x86_64", "i386", "powerpc", "powerpc64", "powerpc64le", "aarch64", "wasm32", "riscv64"]
let withNativeCodeGen
| unregisterised = False
| arch `elem` codegen_arches = True
@@ -139,7 +139,7 @@ inTreeCompilerArgs stg = do
-- For this information, we need to query ghc --info, however, that would
-- require building ghc, which we don't want to do here. Therefore, the
-- logic from `platformHasRTSLinker` is duplicated here.
- let rtsLinker = not $ arch `elem` ["powerpc", "powerpc64", "powerpc64le", "s390x", "riscv64", "loongarch64", "javascript", "wasm32"]
+ let rtsLinker = not $ arch `elem` ["powerpc", "powerpc64", "powerpc64le", "s390x", "loongarch64", "javascript", "wasm32"]
return TestCompilerArgs{..}
Index: ghc-9.10.1/rts/LinkerInternals.h
===================================================================
--- ghc-9.10.1.orig/rts/LinkerInternals.h
+++ ghc-9.10.1/rts/LinkerInternals.h
@@ -208,7 +208,7 @@ typedef struct _Segment {
int n_sections;
} Segment;
-#if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH) || defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH)
+#if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH) || defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH) || defined(riscv64_HOST_ARCH)
#define NEED_SYMBOL_EXTRAS 1
#endif
@@ -220,8 +220,9 @@ typedef struct _Segment {
#define NEED_M32 1
#endif
-/* Jump Islands are sniplets of machine code required for relative
- * address relocations on the PowerPC, x86_64 and ARM.
+/* Jump Islands are sniplets of machine code required for relative address
+ * relocations on the PowerPC, x86_64 and ARM. On RISCV64 we use symbolextras
+ * like a GOT for locals where SymbolExtra represents one entry.
*/
typedef struct {
#if defined(powerpc_HOST_ARCH)
@@ -237,6 +238,8 @@ typedef struct {
uint8_t jumpIsland[8];
#elif defined(arm_HOST_ARCH)
uint8_t jumpIsland[16];
+#elif defined(riscv64_HOST_ARCH)
+ uint64_t addr;
#endif
} SymbolExtra;
Index: ghc-9.10.1/rts/RtsSymbols.c
===================================================================
--- ghc-9.10.1.orig/rts/RtsSymbols.c
+++ ghc-9.10.1/rts/RtsSymbols.c
@@ -980,6 +980,17 @@ extern char **environ;
#define RTS_LIBGCC_SYMBOLS
#endif
+#if defined(riscv64_HOST_ARCH)
+// See https://gcc.gnu.org/onlinedocs/gccint/Integer-library-routines.html as
+// reference for the following built-ins. __clzdi2 and __ctzdi2 probably relate
+// to __builtin-s in libraries/ghc-prim/cbits/ctz.c.
+#define RTS_ARCH_LIBGCC_SYMBOLS \
+ SymI_NeedsProto(__clzdi2) \
+ SymI_NeedsProto(__ctzdi2)
+#else
+#define RTS_ARCH_LIBGCC_SYMBOLS
+#endif
+
// Symbols defined by libgcc/compiler-rt for AArch64's outline atomics.
#if defined(HAVE_ARM_OUTLINE_ATOMICS)
#include "ARMOutlineAtomicsSymbols.h"
@@ -1032,6 +1043,7 @@ RTS_DARWIN_ONLY_SYMBOLS
RTS_OPENBSD_ONLY_SYMBOLS
RTS_LIBC_SYMBOLS
RTS_LIBGCC_SYMBOLS
+RTS_ARCH_LIBGCC_SYMBOLS
RTS_FINI_ARRAY_SYMBOLS
RTS_LIBFFI_SYMBOLS
RTS_ARM_OUTLINE_ATOMIC_SYMBOLS
@@ -1074,6 +1086,7 @@ RtsSymbolVal rtsSyms[] = {
RTS_DARWIN_ONLY_SYMBOLS
RTS_OPENBSD_ONLY_SYMBOLS
RTS_LIBGCC_SYMBOLS
+ RTS_ARCH_LIBGCC_SYMBOLS
RTS_FINI_ARRAY_SYMBOLS
RTS_LIBFFI_SYMBOLS
RTS_ARM_OUTLINE_ATOMIC_SYMBOLS
Index: ghc-9.10.1/rts/adjustor/LibffiAdjustor.c
===================================================================
--- ghc-9.10.1.orig/rts/adjustor/LibffiAdjustor.c
+++ ghc-9.10.1/rts/adjustor/LibffiAdjustor.c
@@ -12,6 +12,7 @@
#include "Adjustor.h"
#include "rts/ghc_ffi.h"
+#include <stdint.h>
#include <string.h>
// Note that ffi_alloc_prep_closure is a non-standard libffi closure
@@ -187,5 +188,21 @@ createAdjustor (int cconv,
barf("createAdjustor: failed to allocate memory");
}
- return (void*)code;
+#if defined(riscv64_HOST_ARCH)
+ // Synchronize the memory and instruction cache to prevent illegal
+ // instruction exceptions.
+
+ // We expect two instructions for address loading, one for the jump.
+ int instrCount = 3;
+ // On Linux the parameters of __builtin___clear_cache are currently unused.
+ // Add them anyways for future compatibility. (I.e. the parameters couldn't
+ // be checked during development.)
+ // TODO: Check the upper boundary e.g. with a debugger.
+ __builtin___clear_cache((void *)code,
+ (void *)((uint64_t *) code + instrCount));
+ // Memory barrier to ensure nothing circumvents the fence.i / cache flush.
+ SEQ_CST_FENCE();
+#endif
+
+ return (void *)code;
}
Index: ghc-9.10.1/rts/linker/Elf.c
===================================================================
--- ghc-9.10.1.orig/rts/linker/Elf.c
+++ ghc-9.10.1/rts/linker/Elf.c
@@ -103,7 +103,8 @@
#include "elf_got.h"
-#if defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH)
+#if defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH) || defined (riscv64_HOST_ARCH)
+# define NEED_GOT
# define NEED_PLT
# include "elf_plt.h"
# include "elf_reloc.h"
@@ -430,10 +431,7 @@ ocVerifyImage_ELF ( ObjectCode* oc )
case EM_AARCH64: IF_DEBUG(linker,debugBelch( "aarch64" )); break;
#endif
#if defined(EM_RISCV)
- case EM_RISCV: IF_DEBUG(linker,debugBelch( "riscv" ));
- errorBelch("%s: RTS linker not implemented on riscv",
- oc->fileName);
- return 0;
+ case EM_RISCV: IF_DEBUG(linker,debugBelch( "riscv" )); break;
#endif
#if defined(EM_LOONGARCH)
case EM_LOONGARCH: IF_DEBUG(linker,debugBelch( "loongarch64" ));
@@ -1130,9 +1128,10 @@ end:
return result;
}
-// the aarch64 linker uses relocacteObjectCodeAarch64,
-// see elf_reloc_aarch64.{h,c}
-#if !defined(aarch64_HOST_ARCH)
+// the aarch64 and riscv64 linkers use relocateObjectCodeAarch64() and
+// relocateObjectCodeRISCV64() (respectively), see elf_reloc_aarch64.{h,c} and
+// elf_reloc_riscv64.{h,c}
+#if !defined(aarch64_HOST_ARCH) && !defined(riscv64_HOST_ARCH)
/* Do ELF relocations which lack an explicit addend. All x86-linux
and arm-linux relocations appear to be of this form. */
@@ -1359,7 +1358,7 @@ do_Elf_Rel_relocations ( ObjectCode* oc,
/* try to locate an existing stub for this target */
if(findStub(&oc->sections[target_shndx], (void**)&S, 0)) {
/* didn't find any. Need to create one */
- if(makeStub(&oc->sections[target_shndx], (void**)&S, 0)) {
+ if(makeStub(&oc->sections[target_shndx], (void**)&S, NULL, 0)) {
errorBelch("Unable to create veneer for ARM_CALL\n");
return 0;
}
@@ -1451,7 +1450,7 @@ do_Elf_Rel_relocations ( ObjectCode* oc,
/* try to locate an existing stub for this target */
if(findStub(&oc->sections[target_shndx], (void**)&S, 1)) {
/* didn't find any. Need to create one */
- if(makeStub(&oc->sections[target_shndx], (void**)&S, 1)) {
+ if(makeStub(&oc->sections[target_shndx], (void**)&S, NULL, 1)) {
errorBelch("Unable to create veneer for ARM_THM_CALL\n");
return 0;
}
@@ -1991,7 +1990,7 @@ ocResolve_ELF ( ObjectCode* oc )
(void) shnum;
(void) shdr;
-#if defined(aarch64_HOST_ARCH)
+#if defined(aarch64_HOST_ARCH) || defined(riscv64_HOST_ARCH)
/* use new relocation design */
if(relocateObjectCode( oc ))
return 0;
@@ -2014,6 +2013,9 @@ ocResolve_ELF ( ObjectCode* oc )
#if defined(powerpc_HOST_ARCH)
ocFlushInstructionCache( oc );
+#elif defined(riscv64_HOST_ARCH)
+ /* New-style pseudo-polymorph (by architecture) call */
+ flushInstructionCache( oc );
#endif
return ocMprotect_Elf(oc);
Index: ghc-9.10.1/rts/linker/ElfTypes.h
===================================================================
--- ghc-9.10.1.orig/rts/linker/ElfTypes.h
+++ ghc-9.10.1/rts/linker/ElfTypes.h
@@ -150,6 +150,7 @@ typedef
struct _Stub {
void * addr;
void * target;
+ void* got_addr;
/* flags can hold architecture specific information they are used during
* lookup of stubs as well. Thus two stubs for the same target with
* different flags are considered unequal.
Index: ghc-9.10.1/rts/linker/SymbolExtras.c
===================================================================
--- ghc-9.10.1.orig/rts/linker/SymbolExtras.c
+++ ghc-9.10.1/rts/linker/SymbolExtras.c
@@ -153,7 +153,7 @@ void ocProtectExtras(ObjectCode* oc)
}
-#if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
+#if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH) || defined(riscv64_HOST_ARCH)
SymbolExtra* makeSymbolExtra( ObjectCode const* oc,
unsigned long symbolNumber,
unsigned long target )
@@ -189,9 +189,12 @@ SymbolExtra* makeSymbolExtra( ObjectCode
extra->addr = target;
memcpy(extra->jumpIsland, jmp, 8);
#endif /* x86_64_HOST_ARCH */
-
+#if defined(riscv64_HOST_ARCH)
+ // Fake GOT entry (used like GOT, but located in symbol extras)
+ extra->addr = target;
+#endif
return extra;
}
-#endif /* powerpc_HOST_ARCH || x86_64_HOST_ARCH */
+#endif /* powerpc_HOST_ARCH || x86_64_HOST_ARCH || riscv64_HOST_ARCH */
#endif /* !x86_64_HOST_ARCH) || !mingw32_HOST_OS */
#endif // NEED_SYMBOL_EXTRAS
Index: ghc-9.10.1/rts/linker/SymbolExtras.h
===================================================================
--- ghc-9.10.1.orig/rts/linker/SymbolExtras.h
+++ ghc-9.10.1/rts/linker/SymbolExtras.h
@@ -16,7 +16,7 @@ SymbolExtra* makeArmSymbolExtra( ObjectC
unsigned long target,
bool fromThumb,
bool toThumb );
-#elif defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
+#elif defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH) || defined(riscv64_HOST_ARCH)
SymbolExtra* makeSymbolExtra( ObjectCode const* oc,
unsigned long symbolNumber,
unsigned long target );
Index: ghc-9.10.1/rts/linker/elf_plt.c
===================================================================
--- ghc-9.10.1.orig/rts/linker/elf_plt.c
+++ ghc-9.10.1/rts/linker/elf_plt.c
@@ -5,7 +5,7 @@
#include <stdint.h>
#include <stdlib.h>
-#if defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH)
+#if defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH) || defined(riscv64_HOST_ARCH)
#if defined(OBJFORMAT_ELF)
#define STRINGIFY(x) #x
@@ -49,11 +49,13 @@ findStub(Section * section,
bool
makeStub(Section * section,
void* * addr,
+ void* got_addr,
uint8_t flags) {
Stub * s = calloc(1, sizeof(Stub));
ASSERT(s != NULL);
s->target = *addr;
+ s->got_addr = got_addr;
s->flags = flags;
s->next = NULL;
s->addr = (uint8_t *)section->info->stub_offset + 8
Index: ghc-9.10.1/rts/linker/elf_plt.h
===================================================================
--- ghc-9.10.1.orig/rts/linker/elf_plt.h
+++ ghc-9.10.1/rts/linker/elf_plt.h
@@ -4,8 +4,9 @@
#include "elf_plt_arm.h"
#include "elf_plt_aarch64.h"
+#include "elf_plt_riscv64.h"
-#if defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH)
+#if defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH) || defined (riscv64_HOST_ARCH)
#if defined(OBJFORMAT_ELF)
@@ -21,6 +22,8 @@
#define __suffix__ Arm
#elif defined(__mips__)
#define __suffix__ Mips
+#elif defined(__riscv)
+#define __suffix__ RISCV64
#else
#error "unknown architecture"
#endif
@@ -34,10 +37,10 @@ unsigned numberOfStubsForSection( Objec
#define STUB_SIZE ADD_SUFFIX(stubSize)
bool findStub(Section * section, void* * addr, uint8_t flags);
-bool makeStub(Section * section, void* * addr, uint8_t flags);
+bool makeStub(Section * section, void* * addr, void* got_addr, uint8_t flags);
void freeStubs(Section * section);
#endif // OBJECTFORMAT_ELF
-#endif // arm/aarch64_HOST_ARCH
+#endif // arm/aarch64_HOST_ARCH/riscv64_HOST_ARCH
Index: ghc-9.10.1/rts/linker/elf_plt_riscv64.c
===================================================================
--- /dev/null
+++ ghc-9.10.1/rts/linker/elf_plt_riscv64.c
@@ -0,0 +1,90 @@
+#include "Rts.h"
+#include "elf_compat.h"
+#include "elf_plt_riscv64.h"
+#include "rts/Messages.h"
+#include "linker/ElfTypes.h"
+
+#include <stdint.h>
+#include <stdlib.h>
+
+#if defined(riscv64_HOST_ARCH)
+
+#if defined(OBJFORMAT_ELF)
+
+const size_t instSizeRISCV64 = 4;
+const size_t stubSizeRISCV64 = 3 * instSizeRISCV64;
+
+bool needStubForRelRISCV64(Elf_Rel *rel) {
+ switch (ELF64_R_TYPE(rel->r_info)) {
+ case R_RISCV_CALL:
+ case R_RISCV_CALL_PLT:
+ return true;
+ default:
+ return false;
+ }
+}
+
+bool needStubForRelaRISCV64(Elf_Rela *rela) {
+ switch (ELF64_R_TYPE(rela->r_info)) {
+ case R_RISCV_CALL:
+ case R_RISCV_CALL_PLT:
+ return true;
+ default:
+ return false;
+ }
+}
+
+// After the global offset table (GOT) has been set up, we can use these three
+// instructions to jump to the target address / function:
+//
+// 1. AUIPC ip, %pcrel_hi(addr)
+// 2. LD ip, %pcrel_lo(addr)(ip)
+// 3. JARL x0, ip, 0
+//
+// We could use the absolute address of the target (because we know it), but
+// that would require loading a 64-bit constant which is a nightmare to do in
+// riscv64 assembly. (See
+// https://github.com/riscv-non-isa/riscv-elf-psabi-doc/blob/5ffe5b5aeedb37b1c1c0c3d94641267d9ad4795a/riscv-elf.adoc#procedure-linkage-table)
+//
+// So far, PC-relative addressing seems to be good enough. If it ever turns out
+// to be not, one could (additionally for out-of-range cases?) encode absolute
+// addressing here.
+bool makeStubRISCV64(Stub *s) {
+ uint32_t *P = (uint32_t *)s->addr;
+ int32_t addr = (uint64_t)s->got_addr - (uint64_t)P;
+
+ uint64_t hi = (addr + 0x800) >> 12;
+ uint64_t lo = addr - (hi << 12);
+
+ IF_DEBUG(
+ linker,
+ debugBelch(
+ "makeStubRISCV64: P = %p, got_addr = %p, target = %p, addr = 0x%x "
+ ", hi = 0x%lx, lo = 0x%lx\n",
+ P, s->got_addr, s->target, addr, hi, lo));
+
+ // AUIPC ip, %pcrel_hi(addr)
+ uint32_t auipcInst = 0b0010111; // opcode
+ auipcInst |= 0x1f << 7; // rd = ip (x31)
+ auipcInst |= hi << 12; // imm[31:12]
+
+ // LD ip, %pcrel_lo(addr)(ip)
+ uint32_t ldInst = 0b0000011; // opcode
+ ldInst |= 0x1f << 7; // rd = ip (x31)
+ ldInst |= 0x1f << 15; // rs = ip (x31)
+ ldInst |= 0b11 << 12; // funct3 = 0x3 (LD)
+ ldInst |= lo << 20; // imm[11:0]
+
+ // JARL x0, ip, 0
+ uint32_t jalrInst = 0b1100111; // opcode
+ jalrInst |= 0x1f << 15; // rs = ip (x31)
+
+ P[0] = auipcInst;
+ P[1] = ldInst;
+ P[2] = jalrInst;
+
+ return EXIT_SUCCESS;
+}
+
+#endif
+#endif
Index: ghc-9.10.1/rts/linker/elf_plt_riscv64.h
===================================================================
--- /dev/null
+++ ghc-9.10.1/rts/linker/elf_plt_riscv64.h
@@ -0,0 +1,12 @@
+#pragma once
+
+#include "LinkerInternals.h"
+
+#if defined(OBJFORMAT_ELF)
+
+extern const size_t stubSizeRISCV64;
+bool needStubForRelRISCV64(Elf_Rel * rel);
+bool needStubForRelaRISCV64(Elf_Rela * rel);
+bool makeStubRISCV64(Stub * s);
+
+#endif
Index: ghc-9.10.1/rts/linker/elf_reloc.c
===================================================================
--- ghc-9.10.1.orig/rts/linker/elf_reloc.c
+++ ghc-9.10.1/rts/linker/elf_reloc.c
@@ -4,13 +4,18 @@
#if defined(OBJFORMAT_ELF)
-/* we currently only use this abstraction for elf/aarch64 */
-#if defined(aarch64_HOST_ARCH)
+/* we currently only use this abstraction for elf/aarch64 and elf/riscv64 */
+#if defined(aarch64_HOST_ARCH) | defined(riscv64_HOST_ARCH)
bool
relocateObjectCode(ObjectCode * oc) {
return ADD_SUFFIX(relocateObjectCode)(oc);
}
+
+
+void flushInstructionCache(ObjectCode * oc){
+ return ADD_SUFFIX(flushInstructionCache)(oc);
+}
#endif
#endif
Index: ghc-9.10.1/rts/linker/elf_reloc.h
===================================================================
--- ghc-9.10.1.orig/rts/linker/elf_reloc.h
+++ ghc-9.10.1/rts/linker/elf_reloc.h
@@ -5,9 +5,10 @@
#if defined(OBJFORMAT_ELF)
#include "elf_reloc_aarch64.h"
+#include "elf_reloc_riscv64.h"
bool
relocateObjectCode(ObjectCode * oc);
-
+void flushInstructionCache(ObjectCode *oc);
#endif /* OBJETFORMAT_ELF */
Index: ghc-9.10.1/rts/linker/elf_reloc_aarch64.c
===================================================================
--- ghc-9.10.1.orig/rts/linker/elf_reloc_aarch64.c
+++ ghc-9.10.1/rts/linker/elf_reloc_aarch64.c
@@ -240,7 +240,7 @@ computeAddend(Section * section, Elf_Rel
/* check if we already have that stub */
if(findStub(section, (void**)&S, 0)) {
/* did not find it. Crete a new stub. */
- if(makeStub(section, (void**)&S, 0)) {
+ if(makeStub(section, (void**)&S, NULL, 0)) {
abort(/* could not find or make stub */);
}
}
@@ -339,5 +339,10 @@ relocateObjectCodeAarch64(ObjectCode * o
return EXIT_SUCCESS;
}
+void flushInstructionCacheAarch64(ObjectCode * oc STG_UNUSED) {
+ // Looks like we don't need this on Aarch64.
+ /* no-op */
+}
+
#endif /* OBJECTFORMAT_ELF */
#endif /* aarch64_HOST_ARCH */
Index: ghc-9.10.1/rts/linker/elf_reloc_aarch64.h
===================================================================
--- ghc-9.10.1.orig/rts/linker/elf_reloc_aarch64.h
+++ ghc-9.10.1/rts/linker/elf_reloc_aarch64.h
@@ -7,4 +7,5 @@
bool
relocateObjectCodeAarch64(ObjectCode * oc);
+void flushInstructionCacheAarch64(ObjectCode *oc);
#endif /* OBJETFORMAT_ELF */
Index: ghc-9.10.1/rts/linker/elf_reloc_riscv64.c
===================================================================
--- /dev/null
+++ ghc-9.10.1/rts/linker/elf_reloc_riscv64.c
@@ -0,0 +1,693 @@
+#include "elf_reloc_riscv64.h"
+#include "LinkerInternals.h"
+#include "Rts.h"
+#include "Stg.h"
+#include "SymbolExtras.h"
+#include "linker/ElfTypes.h"
+#include "elf_plt.h"
+#include "elf_util.h"
+#include "rts/Messages.h"
+#include "util.h"
+
+#include <stdint.h>
+#include <stdlib.h>
+
+#if defined(riscv64_HOST_ARCH)
+
+#if defined(OBJFORMAT_ELF)
+
+typedef uint64_t addr_t;
+
+/* regular instructions are 32bit */
+typedef uint32_t inst_t;
+
+/* compressed instructions are 16bit */
+typedef uint16_t cinst_t;
+
+// TODO: These instances could be static. They are not yet, because we might
+// need their debugging symbols.
+char *relocationTypeToString(Elf64_Xword type);
+int32_t decodeAddendRISCV64(Section *section, Elf_Rel *rel);
+bool encodeAddendRISCV64(Section *section, Elf_Rel *rel, int32_t addend);
+void write8le(uint8_t *p, uint8_t v);
+uint8_t read8le(const uint8_t *P);
+void write16le(cinst_t *p, uint16_t v);
+uint16_t read16le(const cinst_t *P);
+uint32_t read32le(const inst_t *P);
+void write32le(inst_t *p, uint32_t v);
+uint64_t read64le(const uint64_t *P);
+void write64le(uint64_t *p, uint64_t v);
+uint32_t extractBits(uint64_t v, uint32_t begin, uint32_t end);
+void setCJType(cinst_t *loc, uint32_t val);
+void setCBType(cinst_t *loc, uint32_t val);
+void setBType(inst_t *loc, uint32_t val);
+void setSType(inst_t *loc, uint32_t val);
+int32_t computeAddend(ElfRelocationATable * relaTab, unsigned relNo, Elf_Rel *rel, ElfSymbol *symbol,
+ int64_t addend, ObjectCode *oc);
+void setJType(inst_t *loc, uint32_t val);
+void setIType(inst_t *loc, int32_t val);
+void checkInt(inst_t *loc, int32_t v, int n);
+void setUType(inst_t *loc, int32_t val);
+
+
+char *relocationTypeToString(Elf64_Xword type) {
+ switch (ELF64_R_TYPE(type)) {
+ case R_RISCV_NONE:
+ return "R_RISCV_NONE";
+ case R_RISCV_32:
+ return "R_RISCV_32";
+ case R_RISCV_64:
+ return "R_RISCV_64";
+ case R_RISCV_RELATIVE:
+ return "R_RISCV_RELATIVE";
+ case R_RISCV_COPY:
+ return "R_RISCV_COPY";
+ case R_RISCV_JUMP_SLOT:
+ return "R_RISCV_JUMP_SLOT";
+ case R_RISCV_TLS_DTPMOD32:
+ return "R_RISCV_TLS_DTPMOD32";
+ case R_RISCV_TLS_DTPMOD64:
+ return "R_RISCV_TLS_DTPMOD64";
+ case R_RISCV_TLS_DTPREL32:
+ return "R_RISCV_TLS_DTPREL32";
+ case R_RISCV_TLS_DTPREL64:
+ return "R_RISCV_TLS_DTPREL64";
+ case R_RISCV_TLS_TPREL32:
+ return "R_RISCV_TLS_TPREL32";
+ case R_RISCV_TLS_TPREL64:
+ return "R_RISCV_TLS_TPREL64";
+ case R_RISCV_BRANCH:
+ return "R_RISCV_BRANCH";
+ case R_RISCV_JAL:
+ return "R_RISCV_JAL";
+ case R_RISCV_CALL:
+ return "R_RISCV_CALL";
+ case R_RISCV_CALL_PLT:
+ return "R_RISCV_CALL_PLT";
+ case R_RISCV_GOT_HI20:
+ return "R_RISCV_GOT_HI20";
+ case R_RISCV_PCREL_HI20:
+ return "R_RISCV_PCREL_HI20";
+ case R_RISCV_LO12_I:
+ return "R_RISCV_LO12_I";
+ case R_RISCV_PCREL_LO12_I:
+ return "R_RISCV_PCREL_LO12_I";
+ case R_RISCV_HI20:
+ return "R_RISCV_HI20";
+ case R_RISCV_LO12_S:
+ return "R_RISCV_LO12_S";
+ case R_RISCV_PCREL_LO12_S:
+ return "R_RISCV_PCREL_LO12_S";
+ case R_RISCV_RELAX:
+ return "R_RISCV_RELAX";
+ case R_RISCV_RVC_BRANCH:
+ return "R_RISCV_RVC_BRANCH";
+ case R_RISCV_RVC_JUMP:
+ return "R_RISCV_RVC_JUMP";
+ default:
+ return "Unknown relocation type";
+ }
+}
+
+STG_NORETURN
+int32_t decodeAddendRISCV64(Section *section STG_UNUSED,
+ Elf_Rel *rel STG_UNUSED) {
+ barf("decodeAddendRISCV64: Relocations with explicit addend are not supported."
+ " Please open a ticket; providing the causing code/binary.");
+}
+
+// Make sure that V can be represented as an N bit signed integer.
+void checkInt(inst_t *loc, int32_t v, int n) {
+ if (!isInt(n, v)) {
+ barf("Relocation at 0x%x is out of range. value: 0x%x (%d), "
+ "sign-extended value: 0x%x (%d), max bits 0x%x (%d)\n",
+ *loc, v, v, signExtend32(v, n), signExtend32(v, n), n, n);
+ }
+}
+
+// RISCV is little-endian by definition: We can rely on (implicit) casts.
+void write8le(uint8_t *p, uint8_t v) { *p = v; }
+
+// RISCV is little-endian by definition: We can rely on (implicit) casts.
+uint8_t read8le(const uint8_t *p) { return *p; }
+
+// RISCV is little-endian by definition: We can rely on (implicit) casts.
+void write16le(cinst_t *p, uint16_t v) { *p = v; }
+
+// RISCV is little-endian by definition: We can rely on (implicit) casts.
+uint16_t read16le(const cinst_t *p) { return *p; }
+
+// RISCV is little-endian by definition: We can rely on (implicit) casts.
+uint32_t read32le(const inst_t *p) { return *p; }
+
+// RISCV is little-endian by definition: We can rely on (implicit) casts.
+void write32le(inst_t *p, uint32_t v) { *p = v; }
+
+// RISCV is little-endian by definition: We can rely on (implicit) casts.
+uint64_t read64le(const uint64_t *p) { return *p; }
+
+// RISCV is little-endian by definition: We can rely on (implicit) casts.
+void write64le(uint64_t *p, uint64_t v) { *p = v; }
+
+uint32_t extractBits(uint64_t v, uint32_t begin, uint32_t end) {
+ return (v & ((1ULL << (begin + 1)) - 1)) >> end;
+}
+
+// Set immediate val in the instruction at *loc. In U-type instructions the
+// upper 20bits carry the upper 20bits of the immediate.
+void setUType(inst_t *loc, int32_t val) {
+ const unsigned bits = 32;
+ uint32_t hi = val + 0x800;
+ checkInt(loc, signExtend32(hi, bits) >> 12, 20);
+ IF_DEBUG(linker, debugBelch("setUType: hi 0x%x val 0x%x\n", hi, val));
+
+ uint32_t imm = hi & 0xFFFFF000;
+ write32le(loc, (read32le(loc) & 0xFFF) | imm);
+}
+
+// Set immediate val in the instruction at *loc. In I-type instructions the
+// upper 12bits carry the lower 12bit of the immediate.
+void setIType(inst_t *loc, int32_t val) {
+ uint64_t hi = (val + 0x800) >> 12;
+ uint64_t lo = val - (hi << 12);
+
+ IF_DEBUG(linker, debugBelch("setIType: hi 0x%lx lo 0x%lx\n", hi, lo));
+ IF_DEBUG(linker, debugBelch("setIType: loc %p *loc 0x%x val 0x%x\n", loc,
+ *loc, val));
+
+ uint32_t imm = lo & 0xfff;
+ uint32_t instr = (read32le(loc) & 0xfffff) | (imm << 20);
+
+ IF_DEBUG(linker, debugBelch("setIType: insn 0x%x\n", instr));
+ write32le(loc, instr);
+ IF_DEBUG(linker, debugBelch("setIType: loc %p *loc' 0x%x val 0x%x\n", loc,
+ *loc, val));
+}
+
+// Set immediate val in the instruction at *loc. In S-type instructions the
+// lower 12 bits of the immediate are at bits 7 to 11 ([0:4]) and 25 to 31
+// ([5:11]).
+void setSType(inst_t *loc, uint32_t val) {
+ uint64_t hi = (val + 0x800) >> 12;
+ uint64_t lo = val - (hi << 12);
+
+ uint32_t imm = lo;
+ uint32_t instr = (read32le(loc) & 0x1fff07f) | (extractBits(imm, 11, 5) << 25) |
+ (extractBits(imm, 4, 0) << 7);
+
+ write32le(loc, instr);
+}
+
+// Set immediate val in the instruction at *loc. In J-type instructions the
+// immediate has 20bits which are pretty scattered:
+// instr bit -> imm bit
+// 31 -> 20
+// [30:21] -> [10:1]
+// 20 -> 11
+// [19:12] -> [19:12]
+//
+// N.B. bit 0 of the immediate is missing!
+void setJType(inst_t *loc, uint32_t val) {
+ checkInt(loc, val, 21);
+
+ uint32_t insn = read32le(loc) & 0xFFF;
+ uint32_t imm20 = extractBits(val, 20, 20) << 31;
+ uint32_t imm10_1 = extractBits(val, 10, 1) << 21;
+ uint32_t imm11 = extractBits(val, 11, 11) << 20;
+ uint32_t imm19_12 = extractBits(val, 19, 12) << 12;
+ insn |= imm20 | imm10_1 | imm11 | imm19_12;
+
+ write32le(loc, insn);
+}
+
+// Set immediate val in the instruction at *loc. In B-type instructions the
+// immediate has 12bits which are pretty scattered:
+// instr bit -> imm bit
+// 31 -> 12
+// [30:25] -> [10:5]
+// [11:8] -> [4:1]
+// 7 -> 11
+//
+// N.B. bit 0 of the immediate is missing!
+void setBType(inst_t *loc, uint32_t val) {
+ checkInt(loc, val, 13);
+
+ uint32_t insn = read32le(loc) & 0x1FFF07F;
+ uint32_t imm12 = extractBits(val, 12, 12) << 31;
+ uint32_t imm10_5 = extractBits(val, 10, 5) << 25;
+ uint32_t imm4_1 = extractBits(val, 4, 1) << 8;
+ uint32_t imm11 = extractBits(val, 11, 11) << 7;
+ insn |= imm12 | imm10_5 | imm4_1 | imm11;
+
+ write32le(loc, insn);
+}
+
+
+// Set immediate val in the instruction at *loc. CB-type instructions have a
+// lenght of 16 bits (half-word, compared to the usual 32bit/word instructions.)
+// The immediate has 8bits which are pretty scattered:
+// instr bit -> imm bit
+// 12 -> 8
+// [11:10] -> [4:3]
+// [6:5] -> [7:6]
+// [4:3] -> [2:1]
+// 2 -> 5
+//
+// N.B. bit 0 of the immediate is missing!
+void setCBType(cinst_t *loc, uint32_t val) {
+ checkInt((inst_t *)loc, val, 9);
+ uint16_t insn = read16le(loc) & 0xE383;
+ uint16_t imm8 = extractBits(val, 8, 8) << 12;
+ uint16_t imm4_3 = extractBits(val, 4, 3) << 10;
+ uint16_t imm7_6 = extractBits(val, 7, 6) << 5;
+ uint16_t imm2_1 = extractBits(val, 2, 1) << 3;
+ uint16_t imm5 = extractBits(val, 5, 5) << 2;
+ insn |= imm8 | imm4_3 | imm7_6 | imm2_1 | imm5;
+
+ write16le(loc, insn);
+}
+
+// Set immediate val in the instruction at *loc. CJ-type instructions have a
+// lenght of 16 bits (half-word, compared to the usual 32bit/word instructions.)
+// The immediate has 11bits which are pretty scattered:
+// instr bit -> imm bit
+// 12 -> 11
+// 11 -> 4
+// [10:9] ->[9:8]
+// 8 -> 10
+// 7 -> 6
+// 6 -> 7
+// [5:3] -> [3:1]
+// 2 -> 5
+//
+// N.B. bit 0 of the immediate is missing!
+void setCJType(cinst_t *loc, uint32_t val) {
+ checkInt((inst_t *)loc, val, 12);
+ uint16_t insn = read16le(loc) & 0xE003;
+ uint16_t imm11 = extractBits(val, 11, 11) << 12;
+ uint16_t imm4 = extractBits(val, 4, 4) << 11;
+ uint16_t imm9_8 = extractBits(val, 9, 8) << 9;
+ uint16_t imm10 = extractBits(val, 10, 10) << 8;
+ uint16_t imm6 = extractBits(val, 6, 6) << 7;
+ uint16_t imm7 = extractBits(val, 7, 7) << 6;
+ uint16_t imm3_1 = extractBits(val, 3, 1) << 3;
+ uint16_t imm5 = extractBits(val, 5, 5) << 2;
+ insn |= imm11 | imm4 | imm9_8 | imm10 | imm6 | imm7 | imm3_1 | imm5;
+
+ write16le(loc, insn);
+}
+
+// Encode the addend according to the relocaction into the instruction.
+bool encodeAddendRISCV64(Section *section, Elf_Rel *rel, int32_t addend) {
+ // instruction to rewrite (P: Position of the relocation)
+ addr_t P = (addr_t)((uint8_t *)section->start + rel->r_offset);
+ IF_DEBUG(linker,
+ debugBelch(
+ "Relocation type %s 0x%lx (%lu) symbol 0x%lx addend 0x%x (%u / "
+ "%d) P 0x%lx\n",
+ relocationTypeToString(rel->r_info), ELF64_R_TYPE(rel->r_info),
+ ELF64_R_TYPE(rel->r_info), ELF64_R_SYM(rel->r_info), addend,
+ addend, addend, P));
+ switch (ELF64_R_TYPE(rel->r_info)) {
+ case R_RISCV_32_PCREL:
+ case R_RISCV_32:
+ write32le((inst_t *)P, addend);
+ break;
+ case R_RISCV_64:
+ write64le((uint64_t *)P, addend);
+ break;
+ case R_RISCV_GOT_HI20:
+ case R_RISCV_PCREL_HI20:
+ case R_RISCV_HI20: {
+ setUType((inst_t *)P, addend);
+ break;
+ }
+ case R_RISCV_PCREL_LO12_I:
+ case R_RISCV_LO12_I: {
+ setIType((inst_t *)P, addend);
+ break;
+ }
+ case R_RISCV_RVC_JUMP: {
+ setCJType((cinst_t *)P, addend);
+ break;
+ }
+ case R_RISCV_RVC_BRANCH: {
+ setCBType((cinst_t *)P, addend);
+ break;
+ }
+ case R_RISCV_BRANCH: {
+ setBType((inst_t *)P, addend);
+ break;
+ }
+ case R_RISCV_CALL:
+ case R_RISCV_CALL_PLT: {
+ // We could relax more (in some cases) but right now most important is to
+ // make it work.
+ setUType((inst_t *)P, addend);
+ setIType(((inst_t *)P) + 1, addend);
+ break;
+ }
+ case R_RISCV_JAL: {
+ setJType((inst_t *)P, addend);
+ break;
+ }
+ case R_RISCV_ADD8:
+ write8le((uint8_t *)P, read8le((uint8_t *)P) + addend);
+ break;
+ case R_RISCV_ADD16:
+ write16le((cinst_t *)P, read16le((cinst_t *)P) + addend);
+ break;
+ case R_RISCV_ADD32:
+ write32le((inst_t *)P, read32le((inst_t *)P) + addend);
+ break;
+ case R_RISCV_ADD64:
+ write64le((uint64_t *)P, read64le((uint64_t *)P) + addend);
+ break;
+ case R_RISCV_SUB6: {
+ uint8_t keep = *((uint8_t *)P) & 0xc0;
+ uint8_t imm = (((*(uint8_t *)P) & 0x3f) - addend) & 0x3f;
+
+ write8le((uint8_t *)P, keep | imm);
+ break;
+ }
+ case R_RISCV_SUB8:
+ write8le((uint8_t *)P, read8le((uint8_t *)P) - addend);
+ break;
+ case R_RISCV_SUB16:
+ write16le((cinst_t *)P, read16le((cinst_t *)P) - addend);
+ break;
+ case R_RISCV_SUB32:
+ write32le((inst_t *)P, read32le((inst_t *)P) - addend);
+ break;
+ case R_RISCV_SUB64:
+ write64le((uint64_t *)P, read64le((uint64_t *)P) - addend);
+ break;
+ case R_RISCV_SET6: {
+ uint8_t keep = *((uint8_t *)P) & 0xc0;
+ uint8_t imm = (addend & 0x3f) & 0x3f;
+
+ write8le((uint8_t *)P, keep | imm);
+ break;
+ }
+ case R_RISCV_SET8:
+ write8le((uint8_t *)P, addend);
+ break;
+ case R_RISCV_SET16:
+ write16le((cinst_t *)P, addend);
+ break;
+ case R_RISCV_SET32:
+ write32le((inst_t *)P, addend);
+ break;
+ case R_RISCV_PCREL_LO12_S:
+ case R_RISCV_TPREL_LO12_S:
+ case R_RISCV_LO12_S: {
+ setSType((inst_t *)P, addend);
+ break;
+ }
+ case R_RISCV_RELAX:
+ case R_RISCV_ALIGN:
+ // Implementing relaxations (rewriting instructions to more efficient ones)
+ // could be implemented in future. As the code already is aligned and we do
+ // not change the instruction sizes, we should get away with not aligning
+ // (though, that is cheating.) To align or change the instruction count, we
+ // would need machinery to squeeze or extend memory at the current location.
+ break;
+ default:
+ barf("Missing relocation 0x%lx\n", ELF64_R_TYPE(rel->r_info));
+ }
+ return EXIT_SUCCESS;
+}
+
+/**
+ * Compute the *new* addend for a relocation, given a pre-existing addend.
+ * @param section The section the relocation is in.
+ * @param rel The Relocation struct.
+ * @param symbol The target symbol.
+ * @param addend The existing addend. Either explicit or implicit.
+ * @return The new computed addend.
+ */
+int32_t computeAddend(ElfRelocationATable * relaTab, unsigned relNo, Elf_Rel *rel, ElfSymbol *symbol,
+ int64_t addend, ObjectCode *oc) {
+ Section * section = &oc->sections[relaTab->targetSectionIndex];
+
+ // instruction to rewrite (P: Position of the relocation)
+ addr_t P = (addr_t)((uint8_t *)section->start + rel->r_offset);
+
+ CHECK(0x0 != P);
+ CHECK((uint64_t)section->start <= P);
+ CHECK(P <= (uint64_t)section->start + section->size);
+ // S: Value of the symbol in the symbol table
+ addr_t S = (addr_t)symbol->addr;
+ /* GOT slot for the symbol (G + GOT) */
+ addr_t GOT_S = (addr_t)symbol->got_addr;
+
+ // A: Addend field in the relocation entry associated with the symbol
+ int64_t A = addend;
+
+ IF_DEBUG(linker, debugBelch("%s: P 0x%lx S 0x%lx %s GOT_S 0x%lx A 0x%lx relNo %u\n",
+ relocationTypeToString(rel->r_info), P, S,
+ symbol->name, GOT_S, A, relNo));
+ switch (ELF64_R_TYPE(rel->r_info)) {
+ case R_RISCV_32:
+ return S + A;
+ case R_RISCV_64:
+ return S + A;
+ case R_RISCV_HI20:
+ return S + A;
+ case R_RISCV_JUMP_SLOT:
+ return S;
+ case R_RISCV_JAL:
+ return S + A - P;
+ case R_RISCV_PCREL_HI20:
+ return S + A - P;
+ case R_RISCV_LO12_I:
+ return S + A;
+ // Quoting LLVM docs: For R_RISCV_PC_INDIRECT (R_RISCV_PCREL_LO12_{I,S}),
+ // the symbol actually points the corresponding R_RISCV_PCREL_HI20
+ // relocation, and the target VA is calculated using PCREL_HI20's symbol.
+ case R_RISCV_PCREL_LO12_S:
+ FALLTHROUGH;
+ case R_RISCV_PCREL_LO12_I: {
+ // Lookup related HI20 relocation and use that value. I'm still confused why
+ // relocations aren't self-contained, but this is how LLVM does it. And,
+ // calculating the lower 12 bit without any relationship to the GOT entry's
+ // address makes no sense either.
+ for (int64_t i = relNo; i >= 0 ; i--) {
+ Elf_Rela *rel_prime = &relaTab->relocations[i];
+
+ addr_t P_prime =
+ (addr_t)((uint8_t *)section->start + rel_prime->r_offset);
+
+ if (P_prime != S) {
+ // S points to the P of the corresponding *_HI20 relocation.
+ continue;
+ }
+
+ ElfSymbol *symbol_prime =
+ findSymbol(oc, relaTab->sectionHeader->sh_link,
+ ELF64_R_SYM((Elf64_Xword)rel_prime->r_info));
+
+ CHECK(0x0 != symbol_prime);
+
+ /* take explicit addend */
+ int64_t addend_prime = rel_prime->r_addend;
+
+ uint64_t type_prime = ELF64_R_TYPE(rel_prime->r_info);
+
+ if (type_prime == R_RISCV_PCREL_HI20 ||
+ type_prime == R_RISCV_GOT_HI20 ||
+ type_prime == R_RISCV_TLS_GD_HI20 ||
+ type_prime == R_RISCV_TLS_GOT_HI20) {
+ IF_DEBUG(linker,
+ debugBelch(
+ "Found matching relocation: %s (P: 0x%lx, S: 0x%lx, "
+ "sym-name: %s) -> %s (P: 0x%lx, S: %p, sym-name: %s, relNo: %ld)",
+ relocationTypeToString(rel->r_info), P, S, symbol->name,
+ relocationTypeToString(rel_prime->r_info), P_prime,
+ symbol_prime->addr, symbol_prime->name, i));
+ int32_t result = computeAddend(relaTab, i, (Elf_Rel *)rel_prime,
+ symbol_prime, addend_prime, oc);
+ IF_DEBUG(linker, debugBelch("Result of computeAddend: 0x%x (%d)\n",
+ result, result));
+ return result;
+ }
+ }
+ debugBelch("Missing HI relocation for %s: P 0x%lx S 0x%lx %s\n",
+ relocationTypeToString(rel->r_info), P, S, symbol->name);
+ abort();
+ }
+
+ case R_RISCV_RVC_JUMP:
+ return S + A - P;
+ case R_RISCV_RVC_BRANCH:
+ return S + A - P;
+ case R_RISCV_BRANCH:
+ return S + A - P;
+ case R_RISCV_CALL:
+ case R_RISCV_CALL_PLT: {
+ addr_t GOT_Target;
+ if (GOT_S != 0) {
+ // 1. Public symbol with GOT entry.
+ GOT_Target = GOT_S;
+ } else {
+ // 2. Fake GOT entry with symbol extra entry.
+ SymbolExtra *symbolExtra = makeSymbolExtra(oc, ELF_R_SYM(rel->r_info), S);
+ addr_t* FAKE_GOT_S = &symbolExtra->addr;
+ IF_DEBUG(linker, debugBelch("R_RISCV_CALL_PLT w/ SymbolExtra = %p , "
+ "entry = %p\n",
+ symbolExtra, FAKE_GOT_S));
+ GOT_Target = (addr_t) FAKE_GOT_S;
+ }
+
+ if (findStub(section, (void **)&S, 0)) {
+ /* did not find it. Crete a new stub. */
+ if (makeStub(section, (void **)&S, (void *)GOT_Target, 0)) {
+ abort(/* could not find or make stub */);
+ }
+ }
+ IF_DEBUG(linker, debugBelch("R_RISCV_CALL_PLT: S = 0x%lx A = 0x%lx P = "
+ "0x%lx (S + A) - P = 0x%lx \n",
+ S, A, P, (S + A) - P));
+ return (S + A) - P;
+ }
+ case R_RISCV_ADD8:
+ FALLTHROUGH;
+ case R_RISCV_ADD16:
+ FALLTHROUGH;
+ case R_RISCV_ADD32:
+ FALLTHROUGH;
+ case R_RISCV_ADD64:
+ return S + A; // Add V when the value is set
+ case R_RISCV_SUB6:
+ FALLTHROUGH;
+ case R_RISCV_SUB8:
+ FALLTHROUGH;
+ case R_RISCV_SUB16:
+ FALLTHROUGH;
+ case R_RISCV_SUB32:
+ FALLTHROUGH;
+ case R_RISCV_SUB64:
+ return S + A; // Subtract from V when value is set
+ case R_RISCV_SET6:
+ FALLTHROUGH;
+ case R_RISCV_SET8:
+ FALLTHROUGH;
+ case R_RISCV_SET16:
+ FALLTHROUGH;
+ case R_RISCV_SET32:
+ return S + A;
+ case R_RISCV_RELAX:
+ // This "relocation" has no addend.
+ FALLTHROUGH;
+ case R_RISCV_ALIGN:
+ // I guess we don't need to implement this relaxation. Otherwise, this
+ // should return the number of blank bytes to insert via NOPs.
+ return 0;
+ case R_RISCV_32_PCREL:
+ return S + A - P;
+ case R_RISCV_GOT_HI20: {
+ // TODO: Allocating extra memory for every symbol just to play this trick
+ // seems to be a bit obscene. (GOT relocations hitting local symbols
+ // happens, but not very often.) It would be better to allocate only what we
+ // really need.
+
+ // There are two cases here: 1. The symbol is public and has an entry in the
+ // GOT. 2. It's local and has no corresponding GOT entry. The first case is
+ // easy: We simply calculate the addend with the GOT address. In the second
+ // case we create a symbol extra entry and pretend it's the GOT.
+ if (GOT_S != 0) {
+ // 1. Public symbol with GOT entry.
+ return GOT_S + A - P;
+ } else {
+ // 2. Fake GOT entry with symbol extra entry.
+ SymbolExtra *symbolExtra = makeSymbolExtra(oc, ELF_R_SYM(rel->r_info), S);
+ addr_t* FAKE_GOT_S = &symbolExtra->addr;
+ addr_t res = (addr_t) FAKE_GOT_S + A - P;
+ IF_DEBUG(linker, debugBelch("R_RISCV_GOT_HI20 w/ SymbolExtra = %p , "
+ "entry = %p , reloc-addend = 0x%lu ",
+ symbolExtra, FAKE_GOT_S, res));
+ return res;
+ }
+ }
+ default:
+ barf("Unimplemented relocation: 0x%lx\n (%lu)",
+ ELF64_R_TYPE(rel->r_info), ELF64_R_TYPE(rel->r_info));
+ }
+ barf("This should never happen!");
+}
+
+// Iterate over all relocations and perform them.
+bool relocateObjectCodeRISCV64(ObjectCode *oc) {
+ for (ElfRelocationTable *relTab = oc->info->relTable; relTab != NULL;
+ relTab = relTab->next) {
+ /* only relocate interesting sections */
+ if (SECTIONKIND_OTHER == oc->sections[relTab->targetSectionIndex].kind)
+ continue;
+
+ Section *targetSection = &oc->sections[relTab->targetSectionIndex];
+
+ for (unsigned i = 0; i < relTab->n_relocations; i++) {
+ Elf_Rel *rel = &relTab->relocations[i];
+
+ ElfSymbol *symbol = findSymbol(oc, relTab->sectionHeader->sh_link,
+ ELF64_R_SYM((Elf64_Xword)rel->r_info));
+
+ CHECK(0x0 != symbol);
+
+ // This always fails, because we don't support Rel locations, yet: Do we
+ // need this case? Leaving it in to spot the potential bug when it
+ // appears.
+ /* decode implicit addend */
+ int64_t addend = decodeAddendRISCV64(targetSection, rel);
+
+ addend = computeAddend((ElfRelocationATable*) relTab, i, rel, symbol, addend, oc);
+ encodeAddendRISCV64(targetSection, rel, addend);
+ }
+ }
+ for (ElfRelocationATable *relaTab = oc->info->relaTable; relaTab != NULL;
+ relaTab = relaTab->next) {
+ /* only relocate interesting sections */
+ if (SECTIONKIND_OTHER == oc->sections[relaTab->targetSectionIndex].kind)
+ continue;
+
+ Section *targetSection = &oc->sections[relaTab->targetSectionIndex];
+
+ for (unsigned i = 0; i < relaTab->n_relocations; i++) {
+
+ Elf_Rela *rel = &relaTab->relocations[i];
+
+ ElfSymbol *symbol = findSymbol(oc, relaTab->sectionHeader->sh_link,
+ ELF64_R_SYM((Elf64_Xword)rel->r_info));
+
+ CHECK(0x0 != symbol);
+
+ /* take explicit addend */
+ int64_t addend = rel->r_addend;
+
+ addend = computeAddend(relaTab, i, (Elf_Rel *)rel, symbol, addend, oc);
+ encodeAddendRISCV64(targetSection, (Elf_Rel *)rel, addend);
+ }
+ }
+ return EXIT_SUCCESS;
+}
+
+void flushInstructionCacheRISCV64(ObjectCode *oc) {
+ // Synchronize the memory and instruction cache to prevent illegal instruction
+ // exceptions. On Linux the parameters of __builtin___clear_cache are
+ // currently unused. Add them anyways for future compatibility. (I.e. the
+ // parameters couldn't be checked during development.)
+
+ /* The main object code */
+ void *codeBegin = oc->image + oc->misalignment;
+ __builtin___clear_cache(codeBegin, (void*) ((uint64_t*) codeBegin + oc->fileSize));
+
+ /* Jump Islands */
+ __builtin___clear_cache((void *)oc->symbol_extras,
+ (void *)(oc->symbol_extras + oc->n_symbol_extras));
+
+ // Memory barrier to ensure nothing circumvents the fence.i / cache flushes.
+ SEQ_CST_FENCE();
+}
+
+#endif /* OBJECTFORMAT_ELF */
+#endif /* riscv64_HOST_ARCH */
Index: ghc-9.10.1/rts/linker/elf_reloc_riscv64.h
===================================================================
--- /dev/null
+++ ghc-9.10.1/rts/linker/elf_reloc_riscv64.h
@@ -0,0 +1,11 @@
+#pragma once
+
+#include "LinkerInternals.h"
+
+#if defined(OBJFORMAT_ELF)
+
+bool
+relocateObjectCodeRISCV64(ObjectCode * oc);
+
+void flushInstructionCacheRISCV64(ObjectCode *oc);
+#endif /* OBJETFORMAT_ELF */
Index: ghc-9.10.1/rts/rts.cabal
===================================================================
--- ghc-9.10.1.orig/rts/rts.cabal
+++ ghc-9.10.1/rts/rts.cabal
@@ -468,9 +468,11 @@ library
linker/elf_got.c
linker/elf_plt.c
linker/elf_plt_aarch64.c
+ linker/elf_plt_riscv64.c
linker/elf_plt_arm.c
linker/elf_reloc.c
linker/elf_reloc_aarch64.c
+ linker/elf_reloc_riscv64.c
linker/elf_tlsgd.c
linker/elf_util.c
sm/BlockAlloc.c
Index: ghc-9.10.1/testsuite/tests/codeGen/should_run/CCallConv.hs
===================================================================
--- /dev/null
+++ ghc-9.10.1/testsuite/tests/codeGen/should_run/CCallConv.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+-- | This test ensures that sub-word signed and unsigned parameters are correctly
+-- handed over to C functions. I.e. it asserts the calling-convention.
+--
+-- The number of parameters is currently shaped for the RISCV64 calling-convention.
+-- You may need to add more parameters to the C functions in case there are more
+-- registers reserved for parameters in your architecture.
+module Main where
+
+import Data.Word
+import GHC.Exts
+import GHC.Int
+
+foreign import ccall "fun8"
+ fun8 ::
+ Int8# -> -- a0
+ Word8# -> -- a1
+ Int8# -> -- a2
+ Int8# -> -- a3
+ Int8# -> -- a4
+ Int8# -> -- a5
+ Int8# -> -- a6
+ Int8# -> -- a7
+ Word8# -> -- s0
+ Int8# -> -- s1
+ Int64# -- result
+
+foreign import ccall "fun16"
+ fun16 ::
+ Int16# -> -- a0
+ Word16# -> -- a1
+ Int16# -> -- a2
+ Int16# -> -- a3
+ Int16# -> -- a4
+ Int16# -> -- a5
+ Int16# -> -- a6
+ Int16# -> -- a7
+ Word16# -> -- s0
+ Int16# -> -- s1
+ Int64# -- result
+
+foreign import ccall "fun32"
+ fun32 ::
+ Int32# -> -- a0
+ Word32# -> -- a1
+ Int32# -> -- a2
+ Int32# -> -- a3
+ Int32# -> -- a4
+ Int32# -> -- a5
+ Int32# -> -- a6
+ Int32# -> -- a7
+ Word32# -> -- s0
+ Int32# -> -- s1
+ Int64# -- result
+
+foreign import ccall "funFloat"
+ funFloat ::
+ Float# -> -- a0
+ Float# -> -- a1
+ Float# -> -- a2
+ Float# -> -- a3
+ Float# -> -- a4
+ Float# -> -- a5
+ Float# -> -- a6
+ Float# -> -- a7
+ Float# -> -- s0
+ Float# -> -- s1
+ Float# -- result
+
+foreign import ccall "funDouble"
+ funDouble ::
+ Double# -> -- a0
+ Double# -> -- a1
+ Double# -> -- a2
+ Double# -> -- a3
+ Double# -> -- a4
+ Double# -> -- a5
+ Double# -> -- a6
+ Double# -> -- a7
+ Double# -> -- s0
+ Double# -> -- s1
+ Double# -- result
+
+main :: IO ()
+main =
+ -- N.B. the values here aren't choosen by accident: -1 means all bits one in
+ -- twos-complement, which is the same as the max word value.
+ let i8 :: Int8# = intToInt8# (-1#)
+ w8 :: Word8# = wordToWord8# (255##)
+ res8 :: Int64# = fun8 i8 w8 i8 i8 i8 i8 i8 i8 w8 i8
+ expected_res8 :: Int64 = 2 * (fromInteger . fromIntegral) (maxBound :: Word8) + 8 * (-1)
+ i16 :: Int16# = intToInt16# (-1#)
+ w16 :: Word16# = wordToWord16# (65535##)
+ res16 :: Int64# = fun16 i16 w16 i16 i16 i16 i16 i16 i16 w16 i16
+ expected_res16 :: Int64 = 2 * (fromInteger . fromIntegral) (maxBound :: Word16) + 8 * (-1)
+ i32 :: Int32# = intToInt32# (-1#)
+ w32 :: Word32# = wordToWord32# (4294967295##)
+ res32 :: Int64# = fun32 i32 w32 i32 i32 i32 i32 i32 i32 w32 i32
+ expected_res32 :: Int64 = 2 * (fromInteger . fromIntegral) (maxBound :: Word32) + 8 * (-1)
+ resFloat :: Float = F# (funFloat 1.0# 1.1# 1.2# 1.3# 1.4# 1.5# 1.6# 1.7# 1.8# 1.9#)
+ resDouble :: Double = D# (funDouble 1.0## 1.1## 1.2## 1.3## 1.4## 1.5## 1.6## 1.7## 1.8## 1.9##)
+ in do
+ print $ "fun8 result:" ++ show (I64# res8)
+ assertEqual expected_res8 (I64# res8)
+ print $ "fun16 result:" ++ show (I64# res16)
+ assertEqual expected_res16 (I64# res16)
+ print $ "fun32 result:" ++ show (I64# res32)
+ assertEqual expected_res32 (I64# res32)
+ print $ "funFloat result:" ++ show resFloat
+ assertEqual (14.5 :: Float) resFloat
+ print $ "funDouble result:" ++ show resDouble
+ assertEqual (14.5 :: Double) resDouble
+
+assertEqual :: (Eq a, Show a) => a -> a -> IO ()
+assertEqual a b =
+ if a == b
+ then pure ()
+ else error $ show a ++ " =/= " ++ show b
Index: ghc-9.10.1/testsuite/tests/codeGen/should_run/CCallConv.stdout
===================================================================
--- /dev/null
+++ ghc-9.10.1/testsuite/tests/codeGen/should_run/CCallConv.stdout
@@ -0,0 +1,60 @@
+"fun8 result:502"
+"fun16 result:131062"
+"fun32 result:8589934582"
+"funFloat result:14.5"
+"funDouble result:14.5"
+fun32:
+a0: 0xffffffff -1
+a1: 0xffffffff 4294967295
+a2: 0xffffffff -1
+a3: 0xffffffff -1
+a4: 0xffffffff -1
+a5: 0xffffffff -1
+a6: 0xffffffff -1
+a7: 0xffffffff -1
+s0: 0xffffffff -1
+s1: 0xffffffff 4294967295
+fun16:
+a0: 0xffffffff -1
+a1: 0xffff 65535
+a2: 0xffffffff -1
+a3: 0xffffffff -1
+a4: 0xffffffff -1
+a5: 0xffffffff -1
+a6: 0xffffffff -1
+a7: 0xffffffff -1
+s0: 0xffffffff -1
+s1: 0xffff 65535
+fun8:
+a0: 0xffffffff -1
+a1: 0xff 255
+a2: 0xffffffff -1
+a3: 0xffffffff -1
+a4: 0xffffffff -1
+a5: 0xffffffff -1
+a6: 0xffffffff -1
+a7: 0xffffffff -1
+s0: 0xffffffff -1
+s1: 0xff 255
+funFloat:
+a0: 1.000000
+a1: 1.100000
+a2: 1.200000
+a3: 1.300000
+a4: 1.400000
+a5: 1.500000
+a6: 1.600000
+a7: 1.700000
+s0: 1.800000
+s1: 1.900000
+funDouble:
+a0: 1.000000
+a1: 1.100000
+a2: 1.200000
+a3: 1.300000
+a4: 1.400000
+a5: 1.500000
+a6: 1.600000
+a7: 1.700000
+s0: 1.800000
+s1: 1.900000
Index: ghc-9.10.1/testsuite/tests/codeGen/should_run/CCallConv_c.c
===================================================================
--- /dev/null
+++ ghc-9.10.1/testsuite/tests/codeGen/should_run/CCallConv_c.c
@@ -0,0 +1,91 @@
+#include "stdint.h"
+#include "stdio.h"
+
+int64_t fun8(int8_t a0, uint8_t a1, int8_t a2, int8_t a3, int8_t a4, int8_t a5,
+ int8_t a6, int8_t a7, int8_t s0, uint8_t s1) {
+ printf("fun8:\n");
+ printf("a0: %#x %hhd\n", a0, a0);
+ printf("a1: %#x %hhu\n", a1, a1);
+ printf("a2: %#x %hhd\n", a2, a2);
+ printf("a3: %#x %hhd\n", a3, a3);
+ printf("a4: %#x %hhd\n", a4, a4);
+ printf("a5: %#x %hhd\n", a5, a5);
+ printf("a6: %#x %hhd\n", a6, a6);
+ printf("a7: %#x %hhd\n", a7, a7);
+ printf("s0: %#x %hhd\n", s0, s0);
+ printf("s1: %#x %hhu\n", s1, s1);
+
+ return a0 + a1 + a2 + a3 + a4 + a5 + a6 + a7 + s0 + s1;
+}
+
+int64_t fun16(int16_t a0, uint16_t a1, int16_t a2, int16_t a3, int16_t a4,
+ int16_t a5, int16_t a6, int16_t a7, int16_t s0, uint16_t s1) {
+ printf("fun16:\n");
+ printf("a0: %#x %hd\n", a0, a0);
+ printf("a1: %#x %hu\n", a1, a1);
+ printf("a2: %#x %hd\n", a2, a2);
+ printf("a3: %#x %hd\n", a3, a3);
+ printf("a4: %#x %hd\n", a4, a4);
+ printf("a5: %#x %hd\n", a5, a5);
+ printf("a6: %#x %hd\n", a6, a6);
+ printf("a7: %#x %hd\n", a7, a7);
+ printf("s0: %#x %hd\n", s0, s0);
+ printf("s1: %#x %hu\n", s1, s1);
+
+ return a0 + a1 + a2 + a3 + a4 + a5 + a6 + a7 + s0 + s1;
+}
+
+int64_t fun32(int32_t a0, uint32_t a1, int32_t a2, int32_t a3, int32_t a4,
+ int32_t a5, int32_t a6, int32_t a7, int32_t s0, uint32_t s1) {
+ printf("fun32:\n");
+ printf("a0: %#x %d\n", a0, a0);
+ printf("a1: %#x %u\n", a1, a1);
+ printf("a2: %#x %d\n", a2, a2);
+ printf("a3: %#x %d\n", a3, a3);
+ printf("a4: %#x %d\n", a4, a4);
+ printf("a5: %#x %d\n", a5, a5);
+ printf("a6: %#x %d\n", a6, a6);
+ printf("a7: %#x %d\n", a7, a7);
+ printf("s0: %#x %d\n", s0, s0);
+ printf("s1: %#x %u\n", s1, s1);
+
+ // Ensure the addition happens in long int (not just int) precission.
+ // Otherwise, the result is truncated during the operation.
+ int64_t force_int64_precission = 0;
+ return force_int64_precission + a0 + a1 + a2 + a3 + a4 + a5 + a6 + a7 + s0 +
+ s1;
+}
+
+float funFloat(float a0, float a1, float a2, float a3, float a4, float a5,
+ float a6, float a7, float s0, float s1) {
+ printf("funFloat:\n");
+ printf("a0: %f\n", a0);
+ printf("a1: %f\n", a1);
+ printf("a2: %f\n", a2);
+ printf("a3: %f\n", a3);
+ printf("a4: %f\n", a4);
+ printf("a5: %f\n", a5);
+ printf("a6: %f\n", a6);
+ printf("a7: %f\n", a7);
+ printf("s0: %f\n", s0);
+ printf("s1: %f\n", s1);
+
+ return a0 + a1 + a2 + a3 + a4 + a5 + a6 + a7 + s0 + s1;
+}
+
+double funDouble(double a0, double a1, double a2, double a3, double a4, double a5,
+ double a6, double a7, double s0, double s1) {
+ printf("funDouble:\n");
+ printf("a0: %f\n", a0);
+ printf("a1: %f\n", a1);
+ printf("a2: %f\n", a2);
+ printf("a3: %f\n", a3);
+ printf("a4: %f\n", a4);
+ printf("a5: %f\n", a5);
+ printf("a6: %f\n", a6);
+ printf("a7: %f\n", a7);
+ printf("s0: %f\n", s0);
+ printf("s1: %f\n", s1);
+
+ return a0 + a1 + a2 + a3 + a4 + a5 + a6 + a7 + s0 + s1;
+}
Reference in New Issue View Git Blame Copy Permalink