[Git][ghc/ghc][wip/supersven/riscv-ncg] Add flag -fno-empty-fasm
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Mon Apr 10 13:52:29 UTC 2023
Sven Tennie pushed to branch wip/supersven/riscv-ncg at Glasgow Haskell Compiler / GHC
Commits:
1df55c28 by Sven Tennie at 2023-04-10T13:50:14+00:00
Add flag -fno-empty-fasm
This makes it possible to incrementally implement the NCG. Instead of
heaving to be able to compile all .cmm files in GHC.
- - - - -
7 changed files:
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/RISCV64.hs
- compiler/GHC/CmmToAsm/RISCV64/CodeGen.hs
- compiler/GHC/CmmToAsm/RISCV64/Instr.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
Changes:
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -148,10 +148,10 @@ import System.IO
import System.Directory ( getCurrentDirectory )
--------------------
-nativeCodeGen :: forall a . Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle -> UniqSupply
+nativeCodeGen :: forall a . Bool -> Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle -> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
-nativeCodeGen logger ts config modLoc h us cmms
+nativeCodeGen no_empty_asm logger ts config modLoc h us cmms
= let platform = ncgPlatform config
nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr)
=> NcgImpl statics instr jumpDest -> IO a
@@ -167,7 +167,7 @@ nativeCodeGen logger ts config modLoc h us cmms
ArchAlpha -> panic "nativeCodeGen: No NCG for Alpha"
ArchMipseb -> panic "nativeCodeGen: No NCG for mipseb"
ArchMipsel -> panic "nativeCodeGen: No NCG for mipsel"
- ArchRISCV64 -> nCG' (RISCV64.ncgRISCV64 config)
+ ArchRISCV64 -> nCG' (RISCV64.ncgRISCV64 no_empty_asm config)
ArchLoongArch64->panic "nativeCodeGen: No NCG for LoongArch64"
ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch"
ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript"
=====================================
compiler/GHC/CmmToAsm/RISCV64.hs
=====================================
@@ -19,10 +19,10 @@ import qualified GHC.CmmToAsm.RISCV64.CodeGen as RISCV64
import qualified GHC.CmmToAsm.RISCV64.Regs as RISCV64
import qualified GHC.CmmToAsm.RISCV64.RegInfo as RISCV64
-ncgRISCV64 :: NCGConfig -> NcgImpl RawCmmStatics RISCV64.Instr RISCV64.JumpDest
-ncgRISCV64 config = NcgImpl
+ncgRISCV64 :: Bool -> NCGConfig -> NcgImpl RawCmmStatics RISCV64.Instr RISCV64.JumpDest
+ncgRISCV64 no_empty_asm config = NcgImpl
{ ncgConfig = config
- , cmmTopCodeGen = RISCV64.cmmTopCodeGen
+ , cmmTopCodeGen = if no_empty_asm then RISCV64.cmmTopCodeGen else RISCV64.emptyCmmTopCodeGen
, generateJumpTableForInstr = RISCV64.generateJumpTableForInstr
, getJumpDestBlockId = RISCV64.getJumpDestBlockId
, canShortcut = RISCV64.canShortcut
=====================================
compiler/GHC/CmmToAsm/RISCV64/CodeGen.hs
=====================================
@@ -1,15 +1,79 @@
+{-# LANGUAGE GADTs #-}
module GHC.CmmToAsm.RISCV64.CodeGen where
import GHC.CmmToAsm.Types
import GHC.CmmToAsm.Monad
import GHC.CmmToAsm.RISCV64.Instr
import Prelude
+import GHC.Cmm
+import GHC.Cmm.Utils
+import Control.Monad
+import GHC.Cmm.Dataflow.Block
+import GHC.Data.OrdList
+import GHC.Cmm.Dataflow
+import GHC.Driver.Ppr (showPprUnsafe)
+import GHC.Plugins (Outputable)
+import GHC.Driver.Ppr (showSDocUnsafe)
+import GHC.Utils.Outputable
+
+-- | 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.
+emptyCmmTopCodeGen
+ :: RawCmmDecl
+ -> NatM [NatCmmDecl RawCmmStatics Instr]
+-- "TODO: cmmTopCodeGen"
+emptyCmmTopCodeGen _ = return []
cmmTopCodeGen
:: RawCmmDecl
-> NatM [NatCmmDecl RawCmmStatics Instr]
-- "TODO: cmmTopCodeGen"
-cmmTopCodeGen _ = pure []
+cmmTopCodeGen (CmmProc info lab live graph) = do
+ let blocks = toBlockListEntryFirst graph
+ (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
+ let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)
+ tops = proc : concat statics
+ return tops
+cmmTopCodeGen (CmmData sec dat) =
+ return [CmmData sec dat] -- no translation, we just use CmmStatic
+
+basicBlockCodeGen
+ :: Block CmmNode C C
+ -> NatM ( [NatBasicBlock Instr]
+ , [NatCmmDecl RawCmmStatics Instr])
+basicBlockCodeGen block = do
+ let (_, nodes, tail) = blockSplit block
+ id = entryLabel block
+ stmts = blockToList nodes
+ loc_instrs = nilOL
+ mid_instrs <- stmtsToInstrs stmts
+ tail_instrs <- stmtToInstrs tail
+ let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs
+ let
+ (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
+
+ mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
+ = ([], BasicBlock id instrs : blocks, statics)
+ mkBlocks (LDATA sec dat) (instrs,blocks,statics)
+ = error "TODO: basicBlockCodeGen" -- (instrs, blocks, CmmData sec dat:statics)
+ mkBlocks instr (instrs,blocks,statics)
+ = (instr:instrs, blocks, statics)
+ return (BasicBlock id top : other_blocks, statics)
+
+type InstrBlock
+ = OrdList Instr
+
+stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
+stmtsToInstrs stmts
+ = do instrss <- mapM stmtToInstrs stmts
+ return (concatOL instrss)
+
+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
generateJumpTableForInstr :: Instr
-> Maybe (NatCmmDecl RawCmmStatics Instr)
=====================================
compiler/GHC/CmmToAsm/RISCV64/Instr.hs
=====================================
@@ -10,10 +10,22 @@ import GHC.Utils.Outputable
import GHC.Platform.Reg
import GHC.CmmToAsm.Config
import GHC.CmmToAsm.Instr
+import GHC.Cmm
data Instr
-- comment pseudo-op
= COMMENT FastString
+ -- some static data spat out during code
+ -- generation. Will be extracted before
+ -- pretty-printing.
+ | 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
+
allocMoreStack ::
Int
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -63,6 +63,8 @@ import System.IO
import Data.Set (Set)
import qualified Data.Set as Set
+import GHC.Data.EnumSet as EnumSet
+
{-
************************************************************************
* *
@@ -199,9 +201,10 @@ outputAsm logger dflags this_mod location filenm cmm_stream = do
ncg_uniqs <- mkSplitUniqSupply 'n'
debugTraceMsg logger 4 (text "Outputing asm to" <+> text filenm)
let ncg_config = initNCGConfig dflags this_mod
+ no_empty_asm = EnumSet.member Opt_NoEmptyAsm (generalFlags dflags)
{-# SCC "OutputAsm" #-} doOutput filenm $
\h -> {-# SCC "NativeCodeGen" #-}
- nativeCodeGen logger (toolSettings dflags) ncg_config location h ncg_uniqs cmm_stream
+ nativeCodeGen no_empty_asm logger (toolSettings dflags) ncg_config location h ncg_uniqs cmm_stream
{-
************************************************************************
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -217,6 +217,7 @@ data GeneralFlag
| Opt_DistinctConstructorTables
| Opt_InfoTableMap
+ | Opt_NoEmptyAsm
| Opt_WarnIsError -- -Werror; makes warnings fatal
| Opt_ShowWarnGroups -- Show the group a warning belongs to
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -297,6 +297,7 @@ import qualified GHC.Data.EnumSet as EnumSet
import GHC.Foreign (withCString, peekCString)
import qualified GHC.LanguageExtensions as LangExt
+import GHC.Driver.Flags (GeneralFlag(Opt_NoEmptyAsm))
-- Note [Updating flag description in the User's Guide]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2913,6 +2914,8 @@ dynamic_flags_deps = [
(NoArg (setGeneralFlag Opt_DistinctConstructorTables))
, make_ord_flag defGhcFlag "finfo-table-map"
(NoArg (setGeneralFlag Opt_InfoTableMap))
+ , make_ord_flag defGhcFlag "fno-empty-fasm"
+ (NoArg (setGeneralFlag Opt_NoEmptyAsm))
------ Compiler flags -----------------------------------------------
, make_ord_flag defGhcFlag "fasm" (NoArg (setObjBackend ncgBackend))
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1df55c28d4fbbf3139621aca638dc7453035491b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1df55c28d4fbbf3139621aca638dc7453035491b
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/20230410/e7c0cb94/attachment-0001.html>
More information about the ghc-commits
mailing list