[Git][ghc/ghc][wip/supersven/riscv-ncg] cut-though: ppr existing instructions

[Sven Tennie (@supersven)]

Sven Tennie pushed to branch wip/supersven/riscv-ncg at Glasgow Haskell Compiler / GHC


Commits:
7ff2d814 by Sven Tennie at 2023-04-14T15:43:11+00:00
cut-though: ppr existing instructions

- - - - -


3 changed files:

- compiler/GHC/CmmToAsm/RISCV64.hs
- compiler/GHC/CmmToAsm/RISCV64/Instr.hs
- compiler/GHC/CmmToAsm/RISCV64/Ppr.hs


Changes:

=====================================
compiler/GHC/CmmToAsm/RISCV64.hs
=====================================
@@ -29,8 +29,8 @@ ncgRISCV64 no_empty_asm config = NcgImpl
    , canShortcut               = RISCV64.canShortcut
    , shortcutStatics           = RISCV64.shortcutStatics
    , shortcutJump              = RISCV64.shortcutJump
-   , pprNatCmmDeclH            = RISCV64.pprNatCmmDecl
-   , pprNatCmmDeclS            = RISCV64.pprNatCmmDeclS
+   , pprNatCmmDeclH            = RISCV64.pprNatCmmDecl config
+   , pprNatCmmDeclS            = RISCV64.pprNatCmmDecl config
    , maxSpillSlots             = RISCV64.maxSpillSlots config
    , allocatableRegs           = RISCV64.allocatableRegs platform
    , ncgAllocMoreStack         = RISCV64.allocMoreStack


=====================================
compiler/GHC/CmmToAsm/RISCV64/Instr.hs
=====================================
@@ -7,7 +7,6 @@ import GHC.Cmm.Dataflow.Label
 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.Platform.Reg
 import GHC.Types.Unique.Supply
@@ -39,9 +38,6 @@ data Instr
   | -- 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 ->
@@ -250,11 +246,3 @@ mkStackDeallocInstr ::
   Int ->
   [instr]
 mkStackDeallocInstr _ _ = error "TODO: mkStackDeallocInstr"
-
--- | Pretty-print an instruction
-pprInstr :: Platform -> instr -> SDoc
-pprInstr _ _ = error "TODO: pprInstr"
-
--- Create a comment instruction
-mkComment :: FastString -> [instr]
-mkComment _ = error "mkComment"


=====================================
compiler/GHC/CmmToAsm/RISCV64/Ppr.hs
=====================================
@@ -1,5 +1,5 @@
 {-# OPTIONS_GHC -Wno-unused-matches #-}
-
+{-# LANGUAGE MultiParamTypeClasses #-}
 module GHC.CmmToAsm.RISCV64.Ppr where
 
 import GHC.Cmm hiding (topInfoTable)
@@ -16,9 +16,13 @@ import GHC.Types.Basic
 import GHC.Utils.Outputable
 import Prelude hiding ((<>))
 import GHC.CmmToAsm.Utils
+import GHC.Platform.Reg
+import GHC.Utils.Panic
+import GHC.Types.Unique
 
 pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc
-pprNatCmmDecl _ cmmData@(CmmData _ _) = error $ "TODO: pprNatCmmDecl : " ++ showPprUnsafe cmmData
+pprNatCmmDecl config (CmmData _ _) = error "TODO: pprNatCmmDecl "
+
 pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
   let platform = ncgPlatform config
    in pprProcAlignment config
@@ -34,7 +38,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
               $$
               -- 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
+          Just (CmmStaticsRaw info_lbl _) -> error "TODO: pprNatCmmDecl : "
 
 pprProcAlignment :: IsDoc doc => NCGConfig -> doc
 pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config)
@@ -110,7 +114,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) =
     platform = ncgPlatform config
     maybe_infotable c = case mapLookup blockid info_env of
       Nothing -> c
-      Just cmm@(CmmStaticsRaw info_lbl info) -> error $ "pprBasicBlock " ++ showPprUnsafe cmm
+      Just (CmmStaticsRaw info_lbl info) -> error "pprBasicBlock"
 
 pprInstr :: IsDoc doc => Platform -> Instr -> doc
 pprInstr platform instr = case instr of
@@ -123,8 +127,22 @@ pprInstr platform instr = case instr of
   -- 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"
+  J label -> line $ pprJ label
+  LI reg immediate -> line $ pprLI reg immediate
+  where
+    pprLI :: IsLine doc => Reg -> Integer -> doc
+    pprLI reg immediate = text "\tli" <+> pprReg reg <> char ',' <+> (text.show) immediate
+
+    pprReg :: IsLine doc => Reg -> doc
+    pprReg (RegReal (RealRegSingle r)) = text "x" <> (text.show) r
+    pprReg (RegVirtual r) = panic $ "RISCV64.Ppr.ppr: Unexpected virtual register " ++ show r
+
+    pprJ :: IsLine doc => BlockId -> doc
+    pprJ label = text "\tj" <+> pprBlockId label
+
+    pprBlockId:: IsLine doc => BlockId -> doc
+    pprBlockId blockId = pprAsmLabel platform (mkLocalBlockLabel (getUnique blockId))
+
 
 -- aarch64 GNU as uses // for comments.
 asmComment :: SDoc -> SDoc



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7ff2d814aadf95ed7d56bd83fdc7da52c8a9e55d

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7ff2d814aadf95ed7d56bd83fdc7da52c8a9e55d
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/20230414/346e00a3/attachment-0001.html>