[Git][ghc/ghc][wip/supersven/riscv-ncg] 2 commits: hlint
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Thu Apr 13 17:13:26 UTC 2023
Sven Tennie pushed to branch wip/supersven/riscv-ncg at Glasgow Haskell Compiler / GHC
Commits:
c1f7dcf6 by Sven Tennie at 2023-04-10T13:54:09+00:00
hlint
- - - - -
8328acac by Sven Tennie at 2023-04-13T17:13:06+00:00
Save
- - - - -
10 changed files:
- compiler/CodeGen.Platform.h
- compiler/GHC/CmmToAsm/RISCV64.hs
- compiler/GHC/CmmToAsm/RISCV64/CodeGen.hs
- compiler/GHC/CmmToAsm/RISCV64/Instr.hs
- compiler/GHC/CmmToAsm/RISCV64/Ppr.hs
- compiler/GHC/CmmToAsm/RISCV64/Regs.hs
- compiler/GHC/CmmToAsm/Reg/Linear.hs
- compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs
- + compiler/GHC/CmmToAsm/Reg/Linear/RISCV64.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/CodeGen.Platform.h
=====================================
@@ -1086,6 +1086,90 @@ freeReg REG_D6 = False
freeReg _ = True
+#elif defined(MACHREGS_riscv64)
+freeReg 0 = False -- x0 / zero is always 0; not usable in general usage
+
+# if defined(REG_Base)
+freeReg REG_Base = False
+# endif
+# if defined(REG_Sp)
+freeReg REG_Sp = False
+# endif
+# if defined(REG_SpLim)
+freeReg REG_SpLim = False
+# endif
+# if defined(REG_Hp)
+freeReg REG_Hp = False
+# endif
+# if defined(REG_HpLim)
+freeReg REG_HpLim = False
+# endif
+
+# if defined(REG_R1)
+freeReg REG_R1 = False
+# endif
+# if defined(REG_R2)
+freeReg REG_R2 = False
+# endif
+# if defined(REG_R3)
+freeReg REG_R3 = False
+# endif
+# if defined(REG_R4)
+freeReg REG_R4 = False
+# endif
+# if defined(REG_R5)
+freeReg REG_R5 = False
+# endif
+# if defined(REG_R6)
+freeReg REG_R6 = False
+# endif
+# if defined(REG_R7)
+freeReg REG_R7 = False
+# endif
+# if defined(REG_R8)
+freeReg REG_R8 = False
+# endif
+
+# if defined(REG_F1)
+freeReg REG_F1 = False
+# endif
+# if defined(REG_F2)
+freeReg REG_F2 = False
+# endif
+# if defined(REG_F3)
+freeReg REG_F3 = False
+# endif
+# if defined(REG_F4)
+freeReg REG_F4 = False
+# endif
+# if defined(REG_F5)
+freeReg REG_F5 = False
+# endif
+# if defined(REG_F6)
+freeReg REG_F6 = False
+# endif
+
+# if defined(REG_D1)
+freeReg REG_D1 = False
+# endif
+# if defined(REG_D2)
+freeReg REG_D2 = False
+# endif
+# if defined(REG_D3)
+freeReg REG_D3 = False
+# endif
+# if defined(REG_D4)
+freeReg REG_D4 = False
+# endif
+# if defined(REG_D5)
+freeReg REG_D5 = False
+# endif
+# if defined(REG_D6)
+freeReg REG_D6 = False
+# endif
+
+freeReg _ = True
+
#else
freeReg = panic "freeReg not defined for this platform"
=====================================
compiler/GHC/CmmToAsm/RISCV64.hs
=====================================
@@ -18,6 +18,7 @@ import qualified GHC.CmmToAsm.RISCV64.Ppr as RISCV64
import qualified GHC.CmmToAsm.RISCV64.CodeGen as RISCV64
import qualified GHC.CmmToAsm.RISCV64.Regs as RISCV64
import qualified GHC.CmmToAsm.RISCV64.RegInfo as RISCV64
+import GHC.Utils.Outputable
ncgRISCV64 :: Bool -> NCGConfig -> NcgImpl RawCmmStatics RISCV64.Instr RISCV64.JumpDest
ncgRISCV64 no_empty_asm config = NcgImpl
@@ -28,15 +29,18 @@ ncgRISCV64 no_empty_asm config = NcgImpl
, canShortcut = RISCV64.canShortcut
, shortcutStatics = RISCV64.shortcutStatics
, shortcutJump = RISCV64.shortcutJump
- , pprNatCmmDeclH = RISCV64.pprNatCmmDeclH
+ , pprNatCmmDeclH = RISCV64.pprNatCmmDecl
, pprNatCmmDeclS = RISCV64.pprNatCmmDeclS
- , maxSpillSlots = RISCV64.maxSpillSlots
- , allocatableRegs = RISCV64.allocatableRegs
+ , maxSpillSlots = RISCV64.maxSpillSlots config
+ , allocatableRegs = RISCV64.allocatableRegs platform
, ncgAllocMoreStack = RISCV64.allocMoreStack
- , ncgMakeFarBranches = RISCV64.makeFarBranches
+ , ncgMakeFarBranches = const id
, extractUnwindPoints = const []
, invertCondBranches = \_ _ -> id
}
+ where
+ platform = ncgPlatform config
+
-- | Instruction instance for RISC-V 64bit
instance Instruction RISCV64.Instr where
@@ -55,4 +59,4 @@ instance Instruction RISCV64.Instr where
mkStackAllocInstr = RISCV64.mkStackAllocInstr
mkStackDeallocInstr = RISCV64.mkStackDeallocInstr
pprInstr = RISCV64.pprInstr
- mkComment = pure . RISCV64.COMMENT
+ mkComment = pure . RISCV64.COMMENT . ftext
=====================================
compiler/GHC/CmmToAsm/RISCV64/CodeGen.hs
=====================================
@@ -11,10 +11,17 @@ import Control.Monad
import GHC.Cmm.Dataflow.Block
import GHC.Data.OrdList
import GHC.Cmm.Dataflow
-import GHC.Driver.Ppr (showPprUnsafe)
+import GHC.Driver.Ppr ( showPprUnsafe, showSDocUnsafe )
import GHC.Plugins (Outputable)
-import GHC.Driver.Ppr (showSDocUnsafe)
import GHC.Utils.Outputable
+import GHC.Platform
+import GHC.CmmToAsm.Config
+import GHC.Platform.Reg
+import GHC.CmmToAsm.Format
+import GHC.CmmToAsm.RISCV64.Regs
+import GHC.Platform.Regs
+import GHC.Utils.Panic
+import GHC.Cmm.BlockId
-- | Don't try to compile all GHC Cmm files in the beginning.
-- Ignore them. There's a flag to decide we really want to emit something.
@@ -60,9 +67,24 @@ basicBlockCodeGen block = do
= (instr:instrs, blocks, statics)
return (BasicBlock id top : other_blocks, statics)
+--------------------------------------------------------------------------------
+-- | '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)
+
+
stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
stmtsToInstrs stmts
= do instrss <- mapM stmtToInstrs stmts
@@ -72,9 +94,102 @@ stmtToInstrs :: CmmNode e x -> NatM InstrBlock
stmtToInstrs stmt = do
platform <- getPlatform
case stmt of
- CmmComment s -> return (unitOL (COMMENT s))
- a -> error $ "TODO: stmtToInstrs" ++ (showSDocUnsafe . pdoc platform) a
+ CmmComment s -> return (unitOL (COMMENT (ftext s)))
+ -- TODO: Maybe, it would be nice to see the tick comment in assembly?
+ CmmTick {} -> return nilOL
+ CmmAssign reg src
+ | isFloatType ty -> assignReg_FltCode format reg src
+ | otherwise -> assignReg_IntCode format reg src
+ where ty = cmmRegType reg
+ format = cmmTypeFormat ty
+ CmmBranch id -> genBranch id
+ a -> error $ "TODO: stmtToInstrs " ++ (showSDocUnsafe . pdoc platform) a
+
+assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock
+assignReg_FltCode _ _ _ = error "TODO: assignReg_FltCode"
+
+-- TODO: Format parameter unused
+assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock
+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 -> error "TODO: assignReg_IntCode - Fixed"
+
+-- | Grab the Reg for a CmmReg
+getRegisterReg :: Platform -> CmmReg -> Reg
+getRegisterReg _ (CmmLocal (LocalReg u pk))
+ = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)
+getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _))
+ = case globalRegMaybe platform mid of
+ Just reg -> RegReal reg
+ Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal reg)
+
+getRegister :: CmmExpr -> NatM Register
+getRegister e = do
+ config <- getConfig
+ getRegister' config (ncgPlatform config) e
+
+getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register
+ -- Generic case.
+getRegister' config plat expr
+ = case expr of
+ CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _))
+ -> pprPanic "getRegisterReg-memory" (ppr $ PicBaseReg)
+ CmmLit lit
+ -> case lit of
+ CmmInt i W64 -> do
+ return (Any (intFormat W64) (\dst -> unitOL $ annExpr expr (LI dst i)))
+ CmmInt i w -> error ("TODO: getRegister' CmmInt " ++ show i ++ show w ++ " " ++show expr)
+ e -> error ("TODO: getRegister' other " ++ show e)
+ e -> error ("TODO: getRegister'" ++ show e)
+
+-- -----------------------------------------------------------------------------
+-- Unconditional branches
+genBranch :: BlockId -> NatM InstrBlock
+genBranch = return . toOL . mkJumpInstr
+
+
+-- -----------------------------------------------------------------------------
+-- | Utilities
+ann :: SDoc -> Instr -> Instr
+ann doc instr {- debugIsOn -} = ANN doc instr
+-- ann _ instr = 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 oculd 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 instr {- debugIsOn -} = ANN (text . show $ e) instr
+-- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr
+-- annExpr _ instr = instr
+{-# INLINE annExpr #-}
+-- TODO: Consider using jump tables
generateJumpTableForInstr :: Instr
-> Maybe (NatCmmDecl RawCmmStatics Instr)
-generateJumpTableForInstr _ = error "TODO: generateJumpTableForInstr"
+generateJumpTableForInstr _ = Nothing
=====================================
compiler/GHC/CmmToAsm/RISCV64/Instr.hs
=====================================
@@ -1,45 +1,73 @@
+{-# LANGUAGE EmptyCase #-}
module GHC.CmmToAsm.RISCV64.Instr where
-import GHC.Data.FastString
-import GHC.CmmToAsm.Types
+
+import GHC.Cmm
import GHC.Cmm.BlockId
-import GHC.Types.Unique.Supply
import GHC.Cmm.Dataflow.Label
-import Prelude
+import GHC.CmmToAsm.Config
+import GHC.CmmToAsm.Instr hiding (patchRegsOfInstr, takeDeltaInstr, regUsageOfInstr, isMetaInstr, jumpDestsOfInstr)
+import GHC.CmmToAsm.Types
+import GHC.Data.FastString
import GHC.Platform
-import GHC.Utils.Outputable
import GHC.Platform.Reg
-import GHC.CmmToAsm.Config
-import GHC.CmmToAsm.Instr
-import GHC.Cmm
+import GHC.Types.Unique.Supply
+import GHC.Utils.Outputable
+import Prelude
+import GHC.Platform.Regs (freeReg)
data Instr
- -- comment pseudo-op
- = COMMENT FastString
- -- some static data spat out during code
+ = -- comment pseudo-op
+ COMMENT SDoc
+ | MULTILINE_COMMENT SDoc
+ | -- Annotated instruction. Should print <instr> # <doc>
+ ANN SDoc Instr
+ -- specify current stack offset for
+ -- benefit of subsequent passes
+ | DELTA Int
+
+ | -- some static data spat out during code
-- generation. Will be extracted before
-- pretty-printing.
- | LDATA Section RawCmmStatics
-
- -- start a new basic block. Useful during
+ 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
+ NEWBLOCK BlockId
+ | -- load immediate pseudo-instruction
+ LI Reg Integer
+ | -- jump pseudo-instruction
+ J BlockId
+instance Outputable Instr where
+ ppr instr = text "TODO: Outputable Instr ppr"
allocMoreStack ::
- Int
- -> NatCmmDecl statics GHC.CmmToAsm.RISCV64.Instr.Instr
- -> UniqSM (NatCmmDecl statics GHC.CmmToAsm.RISCV64.Instr.Instr, [(BlockId,BlockId)])
+ Int ->
+ NatCmmDecl statics GHC.CmmToAsm.RISCV64.Instr.Instr ->
+ UniqSM (NatCmmDecl statics GHC.CmmToAsm.RISCV64.Instr.Instr, [(BlockId, BlockId)])
allocMoreStack = error "TODO: allocMoreStack"
-maxSpillSlots :: Int
-maxSpillSlots = error "TODO: maxSpillSlots"
+-- saved return address + previous fp
+-- (https://pdos.csail.mit.edu/6.S081/2020/lec/l-riscv.txt)
+stackFrameHeaderSize :: Int
+stackFrameHeaderSize = 2 * spillSlotSize
-makeFarBranches
- :: LabelMap RawCmmStatics
- -> [NatBasicBlock Instr]
- -> [NatBasicBlock Instr]
+-- | All registers are 8 byte wide.
+spillSlotSize :: Int
+spillSlotSize = 8
+
+-- | The number of spill slots available without allocating more.
+maxSpillSlots :: NCGConfig -> Int
+maxSpillSlots config
+-- = 0 -- set to zero, to see when allocMoreStack has to fire.
+ = ((ncgSpillPreallocSize config - stackFrameHeaderSize)
+ `div` spillSlotSize) - 1
+
+makeFarBranches ::
+ LabelMap RawCmmStatics ->
+ [NatBasicBlock Instr] ->
+ [NatBasicBlock Instr]
makeFarBranches _ _ = error "TODO: makeFarBranches"
-- | Get the registers that are being used by this instruction.
@@ -47,66 +75,115 @@ makeFarBranches _ _ = error "TODO: makeFarBranches"
-- 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.
---
-regUsageOfInstr
- :: Platform
- -> instr
- -> RegUsage
-regUsageOfInstr _ _ = error "TODO: regUsageOfInstr"
+regUsageOfInstr ::
+ Platform ->
+ Instr ->
+ RegUsage
+regUsageOfInstr platform instr = case instr of
+ ANN _ i -> regUsageOfInstr platform i
+ COMMENT{} -> usage ([], [])
+ MULTILINE_COMMENT{} -> usage ([], [])
+ LDATA{} -> usage ([], [])
+ DELTA{} -> usage ([], [])
+ NEWBLOCK{} -> usage ([], [])
+ LI reg _ -> usage ([], [reg])
+ -- Looks like J doesn't change registers (beside PC)
+ -- This might be wrong.
+ J{} -> usage ([], [])
+ 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 (src, dst) = RU (filter (interesting platform) src)
+ (filter (interesting platform) dst)
+
+ interesting :: Platform -> Reg -> Bool
+ interesting _ (RegVirtual _) = True
+ interesting platform (RegReal (RealRegSingle i)) = freeReg platform i
+
-- | Apply a given mapping to all the register references in this
-- instruction.
-patchRegsOfInstr
- :: instr
- -> (Reg -> Reg)
- -> instr
-patchRegsOfInstr _ _ = error "TODO: patchRegsOfInstr"
+patchRegsOfInstr ::
+ Instr ->
+ (Reg -> Reg) ->
+ Instr
+patchRegsOfInstr instr env = case instr of
+ ANN _ i -> patchRegsOfInstr i env
+ COMMENT{} -> instr
+ MULTILINE_COMMENT{} -> instr
+ LDATA{} -> instr
+ DELTA{} -> instr
+ NEWBLOCK{} -> instr
+ LI reg i -> LI (env reg) i
+ -- Looks like J doesn't change registers (beside PC)
+ -- This might be wrong.
+ J{} -> instr
+
-- | 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 _ = error "TODO: isJumpishInstr"
+isJumpishInstr :: Instr -> Bool
+isJumpishInstr COMMENT {} = False
+isJumpishInstr MULTILINE_COMMENT {} = False
+isJumpishInstr ANN {} = False
+isJumpishInstr DELTA {} = False
+isJumpishInstr LDATA {} = False
+isJumpishInstr NEWBLOCK {} = False
+isJumpishInstr LI {} = False
+isJumpishInstr J {} = True
--- | Give the possible destinations of this jump instruction.
--- Must be defined for all jumpish instructions.
-jumpDestsOfInstr
- :: instr -> [BlockId]
-jumpDestsOfInstr _ = error "TODO: jumpDestsOfInstr"
+
+-- | 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.
+jumpDestsOfInstr :: Instr -> [BlockId]
+jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i
+jumpDestsOfInstr (J t) = [t]
+jumpDestsOfInstr _ = []
-- | Change the destination of this jump instruction.
-- Used in the linear allocator when adding fixup blocks for join
-- points.
-patchJumpInstr
- :: instr
- -> (BlockId -> BlockId)
- -> instr
+patchJumpInstr ::
+ instr ->
+ (BlockId -> BlockId) ->
+ instr
patchJumpInstr _ _ = error "TODO: patchJumpInstr"
-- | An instruction to spill a register into a spill slot.
-mkSpillInstr
- :: NCGConfig
- -> Reg -- ^ the reg to spill
- -> Int -- ^ the current stack delta
- -> Int -- ^ spill slot to use
- -> [instr] -- ^ instructions
+mkSpillInstr ::
+ NCGConfig ->
+ -- | the reg to spill
+ Reg ->
+ -- | the current stack delta
+ Int ->
+ -- | spill slot to use
+ Int ->
+ -- | instructions
+ [instr]
mkSpillInstr _ _ _ _ = error "TODO: mkSpillInstr"
-- | An instruction to reload a register from a spill slot.
-mkLoadInstr
- :: NCGConfig
- -> Reg -- ^ the reg to reload.
- -> Int -- ^ the current stack delta
- -> Int -- ^ the spill slot to use
- -> [instr] -- ^ instructions
+mkLoadInstr ::
+ NCGConfig ->
+ -- | the reg to reload.
+ Reg ->
+ -- | the current stack delta
+ Int ->
+ -- | the spill slot to use
+ Int ->
+ -- | instructions
+ [instr]
mkLoadInstr _ _ _ _ = error "TODO: mkLoadInstr"
-- | See if this instruction is telling us the current C stack delta
-takeDeltaInstr
- :: instr
- -> Maybe Int
-takeDeltaInstr _ = error "TODO: takeDeltaInstr"
+takeDeltaInstr :: Instr -> Maybe Int
+takeDeltaInstr (ANN _ i) = takeDeltaInstr i
+takeDeltaInstr (DELTA i) = Just i
+takeDeltaInstr _ = Nothing
+
-- | Check whether this instruction is some meta thing inserted into
-- the instruction stream for other purposes.
@@ -115,50 +192,63 @@ takeDeltaInstr _ = error "TODO: takeDeltaInstr"
-- and have its registers allocated.
--
-- eg, comments, delta, ldata, etc.
-isMetaInstr
- :: instr
- -> Bool
-isMetaInstr _ = error "TODO: isMetaInstr"
+isMetaInstr :: Instr -> Bool
+isMetaInstr instr
+ = case instr of
+ ANN _ i -> isMetaInstr i
+ COMMENT{} -> True
+ MULTILINE_COMMENT{} -> True
+ LDATA{} -> True
+ NEWBLOCK{} -> True
+ LI{} -> False
+ J{} -> False
-- | Copy the value in a register to another one.
-- Must work for all register classes.
-mkRegRegMoveInstr
- :: Platform
- -> Reg -- ^ source register
- -> Reg -- ^ destination register
- -> instr
+mkRegRegMoveInstr ::
+ Platform ->
+ -- | source register
+ Reg ->
+ -- | destination register
+ Reg ->
+ instr
mkRegRegMoveInstr _ _ _ = error "TODO: mkRegRegMoveInstr"
-- | Take the source and destination from this reg -> reg move instruction
-- or Nothing if it's not one
-takeRegRegMoveInstr
- :: instr
- -> Maybe (Reg, Reg)
-takeRegRegMoveInstr _ = error "TODO: takeRegRegMoveInstr"
+takeRegRegMoveInstr :: Instr -> Maybe (Reg, Reg)
+takeRegRegMoveInstr COMMENT {} = Nothing
+takeRegRegMoveInstr MULTILINE_COMMENT {} = Nothing
+takeRegRegMoveInstr ANN {} = Nothing
+takeRegRegMoveInstr DELTA {} = Nothing
+takeRegRegMoveInstr LDATA {} = Nothing
+takeRegRegMoveInstr NEWBLOCK {} = Nothing
+takeRegRegMoveInstr LI {} = Nothing
+takeRegRegMoveInstr J {} = Nothing
-- | Make an unconditional jump instruction.
-- For architectures with branch delay slots, its ok to put
-- a NOP after the jump. Don't fill the delay slot with an
-- instruction that references regs or you'll confuse the
-- linear allocator.
-mkJumpInstr
- :: BlockId
- -> [instr]
-mkJumpInstr _ = error "TODO: mkJumpInstr"
+mkJumpInstr ::
+ BlockId ->
+ [Instr]
+mkJumpInstr id = [J id]
-- Subtract an amount from the C stack pointer
-mkStackAllocInstr
- :: Platform
- -> Int
- -> [instr]
+mkStackAllocInstr ::
+ Platform ->
+ Int ->
+ [instr]
mkStackAllocInstr _ _ = error "TODO: mkStackAllocInstr"
-- Add an amount to the C stack pointer
-mkStackDeallocInstr
- :: Platform
- -> Int
- -> [instr]
+mkStackDeallocInstr ::
+ Platform ->
+ Int ->
+ [instr]
mkStackDeallocInstr _ _ = error "TODO: mkStackDeallocInstr"
-- | Pretty-print an instruction
=====================================
compiler/GHC/CmmToAsm/RISCV64/Ppr.hs
=====================================
@@ -1,11 +1,137 @@
+{-# OPTIONS_GHC -Wno-unused-matches #-}
+
module GHC.CmmToAsm.RISCV64.Ppr where
-import GHC.Utils.Outputable
+
+import GHC.Cmm hiding (topInfoTable)
+import GHC.Cmm.BlockId
+import GHC.Cmm.CLabel
+import GHC.Cmm.Dataflow.Collections
+import GHC.Cmm.Dataflow.Label
+import GHC.CmmToAsm.Config
+import GHC.CmmToAsm.Ppr
+import GHC.CmmToAsm.RISCV64.Instr hiding (pprInstr)
import GHC.CmmToAsm.Types
-import GHC.CmmToAsm.RISCV64.Instr
-import Prelude
+import GHC.Platform
+import GHC.Types.Basic
+import GHC.Utils.Outputable
+import Prelude hiding ((<>))
+import GHC.CmmToAsm.Utils
+
+pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc
+pprNatCmmDecl _ cmmData@(CmmData _ _) = error $ "TODO: pprNatCmmDecl : " ++ showPprUnsafe cmmData
+pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
+ let platform = ncgPlatform config
+ in pprProcAlignment config
+ $$ 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
+ $$
+ -- TODO: Is this call to pprSizeDecl needed? (Doc states this .size is only for source compatibility.)
+ pprSizeDecl platform lbl
+ Just cmmStaticsRaw@(CmmStaticsRaw info_lbl _) -> error $ "TODO: pprNatCmmDecl : " ++ show cmmStaticsRaw
+
+pprProcAlignment :: IsDoc doc => NCGConfig -> doc
+pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config)
+ where
+ platform = ncgPlatform config
+
+pprAlign :: IsDoc doc => Platform -> Alignment -> doc
+pprAlign _platform alignment =
+ line $ text "\t.balign " <> int (alignmentBytes alignment)
+
+pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc
+pprSectionAlign _config (Section (OtherSection _) _) =
+ error "AArch64.Ppr.pprSectionAlign: unknown section"
+pprSectionAlign config sec@(Section seg _) =
+ line (pprSectionHeader config sec)
+ $$ pprAlignForSection (ncgPlatform config) seg
+
+-- | Print appropriate alignment for the given section type.
+pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc
+pprAlignForSection _platform _seg =
+ -- .balign is stable, whereas .align is platform dependent.
+ line (text "\t.balign 8") -- always 8
+
+pprLabel :: IsDoc doc => Platform -> CLabel -> doc
+pprLabel platform lbl =
+ pprGloblDecl platform lbl
+ $$ pprTypeDecl platform lbl
+ $$ line (pprAsmLabel platform lbl <> char ':')
+
+pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc
+pprGloblDecl platform lbl
+ | not (externallyVisibleCLabel lbl) = empty
+ | otherwise = line (text "\t.globl " <> pprAsmLabel platform lbl)
+
+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
+
+-- | Output the ELF .size directive.
+pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc
+pprSizeDecl platform lbl =
+ if osElfTarget (platformOS platform)
+ then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl)
+ else 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) instrs)
+ where
+ asmLbl = blockLbl blockid
+ platform = ncgPlatform config
+ maybe_infotable c = case mapLookup blockid info_env of
+ Nothing -> c
+ Just cmm@(CmmStaticsRaw info_lbl info) -> error $ "pprBasicBlock " ++ showPprUnsafe cmm
+
+pprInstr :: IsDoc doc => Platform -> Instr -> doc
+pprInstr platform instr = case instr of
+ -- Meta Instructions ---------------------------------------------------------
+ -- 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)
+ DELTA d -> dualDoc (asmComment $ text "\tdelta = " <> int d) empty
+ -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable
+ NEWBLOCK _ -> error "pprInstr: NEWBLOCK"
+ LDATA _ _ -> error "pprInstr: LDATA"
+ J t -> error "pprInstr: LDATA"
+ LI reg i -> error "pprInstr: LDATA"
+
+-- aarch64 GNU as uses // for comments.
+asmComment :: SDoc -> SDoc
+asmComment c = whenPprDebug $ text "#" <+> c
-pprNatCmmDeclH :: IsDoc doc => NatCmmDecl RawCmmStatics Instr -> doc
-pprNatCmmDeclH _ = error "TODO: pprNatCmmDeclH"
+asmDoubleslashComment :: SDoc -> SDoc
+asmDoubleslashComment c = whenPprDebug $ text "//" <+> c
-pprNatCmmDeclS :: IsDoc doc => NatCmmDecl RawCmmStatics Instr -> doc
-pprNatCmmDeclS _ = error "TODO: pprNatCmmDeclS"
+asmMultilineComment :: SDoc -> SDoc
+asmMultilineComment c = whenPprDebug $ text "/*" $+$ c $+$ text "*/"
=====================================
compiler/GHC/CmmToAsm/RISCV64/Regs.hs
=====================================
@@ -1,6 +1,28 @@
module GHC.CmmToAsm.RISCV64.Regs where
import GHC.Platform.Reg
import Prelude
+import GHC.CmmToAsm.Format
+import GHC.Utils.Panic
+import GHC.Types.Unique
+import GHC.Platform
+import GHC.Platform.Regs
-allocatableRegs :: [RealReg]
-allocatableRegs = error "TODO: allocatableRegs"
+allMachRegNos :: [RegNo]
+allMachRegNos = [1..31] ++ [32..63]
+
+-- allocatableRegs is allMachRegNos with the fixed-use regs removed.
+-- i.e., these are the regs for which we are prepared to allow the
+-- register allocator to attempt to map VRegs to.
+allocatableRegs :: Platform -> [RealReg]
+allocatableRegs platform
+ = let isFree i = freeReg platform i
+ in map RealRegSingle $ filter isFree allMachRegNos
+
+mkVirtualReg :: Unique -> Format -> VirtualReg
+mkVirtualReg u format
+ | not (isFloatFormat format) = VirtualRegI u
+ | otherwise
+ = case format of
+ FF32 -> VirtualRegD u
+ FF64 -> VirtualRegD u
+ _ -> panic "RISCV64.mkVirtualReg"
=====================================
compiler/GHC/CmmToAsm/Reg/Linear.hs
=====================================
@@ -114,6 +114,7 @@ import qualified GHC.CmmToAsm.Reg.Linear.PPC as PPC
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.RISCV64 as RISCV64
import GHC.CmmToAsm.Reg.Target
import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Reg.Utils
@@ -223,7 +224,7 @@ linearRegAlloc config entry_ids block_live sccs
ArchAlpha -> panic "linearRegAlloc ArchAlpha"
ArchMipseb -> panic "linearRegAlloc ArchMipseb"
ArchMipsel -> panic "linearRegAlloc ArchMipsel"
- ArchRISCV64 -> panic "linearRegAlloc ArchRISCV64"
+ ArchRISCV64 -> go $ (frInitFreeRegs platform :: RISCV64.FreeRegs)
ArchLoongArch64-> panic "linearRegAlloc ArchLoongArch64"
ArchJavaScript -> panic "linearRegAlloc ArchJavaScript"
ArchWasm32 -> panic "linearRegAlloc ArchWasm32"
=====================================
compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs
=====================================
@@ -29,10 +29,12 @@ import qualified GHC.CmmToAsm.Reg.Linear.PPC as PPC
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.RISCV64 as RISCV64
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.RISCV64.Instr as RISCV64.Instr
class Show freeRegs => FR freeRegs where
frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs
@@ -64,6 +66,13 @@ instance FR AArch64.FreeRegs where
frInitFreeRegs = AArch64.initFreeRegs
frReleaseReg = \_ -> AArch64.releaseReg
+instance FR RISCV64.FreeRegs where
+ frAllocateReg = \_ -> RISCV64.allocateReg
+ frGetFreeRegs = \_ -> RISCV64.getFreeRegs
+ frInitFreeRegs = RISCV64.initFreeRegs
+ frReleaseReg = \_ -> RISCV64.releaseReg
+
+
maxSpillSlots :: NCGConfig -> Int
maxSpillSlots config = case platformArch (ncgPlatform config) of
ArchX86 -> X86.Instr.maxSpillSlots config
@@ -76,7 +85,7 @@ maxSpillSlots config = case platformArch (ncgPlatform config) of
ArchAlpha -> panic "maxSpillSlots ArchAlpha"
ArchMipseb -> panic "maxSpillSlots ArchMipseb"
ArchMipsel -> panic "maxSpillSlots ArchMipsel"
- ArchRISCV64 -> panic "maxSpillSlots ArchRISCV64"
+ ArchRISCV64 -> RISCV64.Instr.maxSpillSlots config
ArchLoongArch64->panic "maxSpillSlots ArchLoongArch64"
ArchJavaScript-> panic "maxSpillSlots ArchJavaScript"
ArchWasm32 -> panic "maxSpillSlots ArchWasm32"
=====================================
compiler/GHC/CmmToAsm/Reg/Linear/RISCV64.hs
=====================================
@@ -0,0 +1,69 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- | Free regs map for RISC-V 64bit
+module GHC.CmmToAsm.Reg.Linear.RISCV64 where
+
+import GHC.Prelude
+
+import GHC.CmmToAsm.RISCV64.Regs
+import GHC.Platform.Reg.Class
+import GHC.Platform.Reg
+
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Platform
+
+import Data.Word
+
+import GHC.Stack
+
+-- TODO: Register selection can likely be smart. Re-check this. (I'm not even sure this is correct.)
+data FreeRegs = FreeRegs !Word32 !Word32
+
+instance Show FreeRegs where
+ show (FreeRegs g f) = "FreeRegs: " ++ showBits g ++ "; " ++ showBits f
+
+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"
+
+noFreeRegs :: FreeRegs
+noFreeRegs = FreeRegs 0 0
+
+showBits :: Word32 -> String
+showBits w = map (\i -> if testBit w i then '1' else '0') [0..31]
+
+-- FR instance implementation (See Linear.FreeRegs)
+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.RISCV64.allocReg: double allocation of float reg v" ++ show (r - 32) ++ "; " ++ showBits f
+ | otherwise = pprPanic "Linear.RISCV64.allocReg" $ text ("double allocation of gp reg x" ++ show r ++ "; " ++ showBits g)
+
+getFreeRegs :: RegClass -> FreeRegs -> [RealReg]
+getFreeRegs cls (FreeRegs g f)
+ -- TODO: how to handle small floats?
+ | RcFloat <- cls = [] -- For now we only support double and integer registers, floats will need to be promoted.
+ | RcDouble <- cls = go 32 f 31
+ | RcInteger <- cls = go 1 g 30
+ where
+ go _ _ i | i < 0 = []
+ go off x i | testBit x i = RealRegSingle (off + i) : (go off x $! i - 1)
+ | otherwise = go off x $! i - 1
+
+initFreeRegs :: Platform -> FreeRegs
+initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)
+
+releaseReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs
+releaseReg (RealRegSingle r) (FreeRegs g f)
+ | r > 31 && testBit f (r - 32) = pprPanic "Linear.RISCV64.releaseReg" (text "can't release non-allocated reg v" <> int (r - 32))
+ | r < 32 && testBit g r = pprPanic "Linear.RISCV64.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
=====================================
compiler/ghc.cabal.in
=====================================
@@ -253,6 +253,7 @@ Library
GHC.CmmToAsm.Reg.Linear.FreeRegs
GHC.CmmToAsm.Reg.Linear.JoinToTargets
GHC.CmmToAsm.Reg.Linear.PPC
+ GHC.CmmToAsm.Reg.Linear.RISCV64
GHC.CmmToAsm.Reg.Linear.StackMap
GHC.CmmToAsm.Reg.Linear.State
GHC.CmmToAsm.Reg.Linear.Stats
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1df55c28d4fbbf3139621aca638dc7453035491b...8328acac55b046f522531208c8b3cf9068d3069a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1df55c28d4fbbf3139621aca638dc7453035491b...8328acac55b046f522531208c8b3cf9068d3069a
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230413/9577f0d9/attachment-0001.html>
More information about the ghc-commits
mailing list