[Git][ghc/ghc][master] 3 commits: Testsuite: measure compiler stats for T16190
Marge Bot
gitlab at gitlab.haskell.org
Fri Apr 3 10:27:08 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
f7597aa0 by Sylvain Henry at 2020-04-03T06:26:54-04:00
Testsuite: measure compiler stats for T16190
We were mistakenly measuring program stats
- - - - -
a485c3c4 by Sylvain Henry at 2020-04-03T06:26:54-04:00
Move blob handling into StgToCmm
Move handling of big literal strings from CmmToAsm to StgToCmm. It
avoids the use of `sdocWithDynFlags` (cf #10143). We might need to move
this handling even higher in the pipeline in the future (cf #17960):
this patch will make it easier.
- - - - -
cc2918a0 by Sylvain Henry at 2020-04-03T06:26:54-04:00
Refactor CmmStatics
In !2959 we noticed that there was some redundant code (in GHC.Cmm.Utils
and GHC.Cmm.StgToCmm.Utils) used to deal with `CmmStatics` datatype
(before SRT generation) and `RawCmmStatics` datatype (after SRT
generation).
This patch removes this redundant code by using a single GADT for
(Raw)CmmStatics.
- - - - -
28 changed files:
- compiler/GHC/Cmm.hs
- compiler/GHC/Cmm/DebugBlock.hs
- compiler/GHC/Cmm/Info.hs
- compiler/GHC/Cmm/Info/Build.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Cmm/Ppr/Decl.hs
- compiler/GHC/Cmm/Utils.hs
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs
- compiler/GHC/CmmToAsm/PPC/Ppr.hs
- compiler/GHC/CmmToAsm/PPC/RegInfo.hs
- compiler/GHC/CmmToAsm/Ppr.hs
- compiler/GHC/CmmToAsm/SPARC/CodeGen.hs
- compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs
- compiler/GHC/CmmToAsm/SPARC/Ppr.hs
- compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/Instr.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/CmmToC.hs
- compiler/GHC/CmmToLlvm.hs
- compiler/GHC/CmmToLlvm/Data.hs
- compiler/GHC/CmmToLlvm/Ppr.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Hpc.hs
- compiler/GHC/StgToCmm/Prof.hs
- compiler/GHC/StgToCmm/Ticky.hs
- compiler/GHC/StgToCmm/Utils.hs
- testsuite/tests/perf/compiler/all.T
Changes:
=====================================
compiler/GHC/Cmm.hs
=====================================
@@ -1,5 +1,8 @@
-- Cmm representations using Hoopl's Graph CmmNode e x.
{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitNamespaces #-}
module GHC.Cmm (
-- * Cmm top-level datatypes
@@ -7,7 +10,8 @@ module GHC.Cmm (
CmmDecl, CmmDeclSRTs, GenCmmDecl(..),
CmmGraph, GenCmmGraph(..),
CmmBlock, RawCmmDecl,
- Section(..), SectionType(..), CmmStatics(..), RawCmmStatics(..), CmmStatic(..),
+ Section(..), SectionType(..),
+ GenCmmStatics(..), type CmmStatics, type RawCmmStatics, CmmStatic(..),
isSecConstant,
-- ** Blocks containing lists
@@ -197,28 +201,31 @@ data Section = Section SectionType CLabel
data CmmStatic
= CmmStaticLit CmmLit
- -- a literal value, size given by cmmLitRep of the literal.
+ -- ^ a literal value, size given by cmmLitRep of the literal.
| CmmUninitialised Int
- -- uninitialised data, N bytes long
+ -- ^ uninitialised data, N bytes long
| CmmString ByteString
- -- string of 8-bit values only, not zero terminated.
+ -- ^ string of 8-bit values only, not zero terminated.
+ | CmmFileEmbed FilePath
+ -- ^ an embedded binary file
-- Static data before SRT generation
-data CmmStatics
- = CmmStatics
- CLabel -- Label of statics
- CmmInfoTable
- CostCentreStack
- [CmmLit] -- Payload
- | CmmStaticsRaw
- CLabel -- Label of statics
- [CmmStatic] -- The static data itself
-
--- Static data, after SRTs are generated
-data RawCmmStatics
- = RawCmmStatics
- CLabel -- Label of statics
- [CmmStatic] -- The static data itself
+data GenCmmStatics (rawOnly :: Bool) where
+ CmmStatics
+ :: CLabel -- Label of statics
+ -> CmmInfoTable
+ -> CostCentreStack
+ -> [CmmLit] -- Payload
+ -> GenCmmStatics 'False
+
+ -- | Static data, after SRTs are generated
+ CmmStaticsRaw
+ :: CLabel -- Label of statics
+ -> [CmmStatic] -- The static data itself
+ -> GenCmmStatics a
+
+type CmmStatics = GenCmmStatics 'False
+type RawCmmStatics = GenCmmStatics 'True
-- -----------------------------------------------------------------------------
-- Basic blocks consisting of lists
=====================================
compiler/GHC/Cmm/DebugBlock.hs
=====================================
@@ -162,7 +162,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
= DebugBlock { dblProcedure = g_entry graph
, dblLabel = label
, dblCLabel = case info of
- Just (RawCmmStatics infoLbl _) -> infoLbl
+ Just (CmmStaticsRaw infoLbl _) -> infoLbl
Nothing
| g_entry graph == label -> entryLbl
| otherwise -> blockLbl label
=====================================
compiler/GHC/Cmm/Info.hs
=====================================
@@ -167,7 +167,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info
rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
--
- return (top_decls, (lbl, RawCmmStatics info_lbl $ map CmmStaticLit $
+ return (top_decls, (lbl, CmmStaticsRaw info_lbl $ map CmmStaticLit $
reverse rel_extra_bits ++ rel_std_info))
-----------------------------------------------------
=====================================
compiler/GHC/Cmm/Info/Build.hs
=====================================
@@ -1107,10 +1107,10 @@ updInfoSRTs
-> [CmmDeclSRTs]
updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics))
- = [CmmData s (RawCmmStatics lbl statics)]
+ = [CmmData s (CmmStaticsRaw lbl statics)]
updInfoSRTs dflags _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload))
- = [CmmData s (RawCmmStatics lbl (map CmmStaticLit field_lits))]
+ = [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))]
where
caf_info = if caffy then MayHaveCafRefs else NoCafRefs
field_lits = mkStaticClosureFields dflags itbl ccs caf_info payload
=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -1167,7 +1167,7 @@ staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
staticClosure pkg cl_label info payload
= do dflags <- getDynFlags
let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
- code $ emitRawDataLits (mkCmmDataLabel pkg cl_label) lits
+ code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
foreignCall
:: String
=====================================
compiler/GHC/Cmm/Ppr/Decl.hs
=====================================
@@ -1,3 +1,5 @@
+{-# LANGUAGE GADTs #-}
+
----------------------------------------------------------------------------
--
-- Pretty-printing of common Cmm types
@@ -70,12 +72,9 @@ instance (Outputable d, Outputable info, Outputable i)
=> Outputable (GenCmmDecl d info i) where
ppr t = pprTop t
-instance Outputable CmmStatics where
+instance Outputable (GenCmmStatics a) where
ppr = pprStatics
-instance Outputable RawCmmStatics where
- ppr = pprRawStatics
-
instance Outputable CmmStatic where
ppr e = sdocWithDynFlags $ \dflags ->
pprStatic (targetPlatform dflags) e
@@ -142,19 +141,17 @@ instance Outputable ForeignHint where
-- following C--
--
-pprStatics :: CmmStatics -> SDoc
+pprStatics :: GenCmmStatics a -> SDoc
pprStatics (CmmStatics lbl itbl ccs payload) =
ppr lbl <> colon <+> ppr itbl <+> ppr ccs <+> ppr payload
-pprStatics (CmmStaticsRaw lbl ds) = pprRawStatics (RawCmmStatics lbl ds)
-
-pprRawStatics :: RawCmmStatics -> SDoc
-pprRawStatics (RawCmmStatics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)
+pprStatics (CmmStaticsRaw lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)
pprStatic :: Platform -> CmmStatic -> SDoc
pprStatic platform s = case s of
CmmStaticLit lit -> nest 4 $ text "const" <+> pprLit platform lit <> semi
CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
+ CmmFileEmbed path -> nest 4 $ text "incbin " <+> text (show path)
-- --------------------------------------------------------------------------
-- data sections
=====================================
compiler/GHC/Cmm/Utils.hs
=====================================
@@ -20,7 +20,7 @@ module GHC.Cmm.Utils(
-- CmmLit
zeroCLit, mkIntCLit,
mkWordCLit, packHalfWordsCLit,
- mkByteStringCLit,
+ mkByteStringCLit, mkFileEmbedLit,
mkDataLits, mkRODataLits,
mkStgWordCLit,
@@ -195,23 +195,29 @@ zeroExpr platform = CmmLit (zeroCLit platform)
mkWordCLit :: Platform -> Integer -> CmmLit
mkWordCLit platform wd = CmmInt wd (wordWidth platform)
+-- | We make a top-level decl for the string, and return a label pointing to it
mkByteStringCLit
- :: CLabel -> ByteString -> (CmmLit, GenCmmDecl RawCmmStatics info stmt)
--- We have to make a top-level decl for the string,
--- and return a literal pointing to it
+ :: CLabel -> ByteString -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
mkByteStringCLit lbl bytes
- = (CmmLabel lbl, CmmData (Section sec lbl) $ RawCmmStatics lbl [CmmString bytes])
+ = (CmmLabel lbl, CmmData (Section sec lbl) $ CmmStaticsRaw lbl [CmmString bytes])
where
-- This can not happen for String literals (as there \NUL is replaced by
-- C0 80). However, it can happen with Addr# literals.
sec = if 0 `BS.elem` bytes then ReadOnlyData else CString
-mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl RawCmmStatics info stmt
--- Build a data-segment data block
+-- | We make a top-level decl for the embedded binary file, and return a label pointing to it
+mkFileEmbedLit
+ :: CLabel -> FilePath -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
+mkFileEmbedLit lbl path
+ = (CmmLabel lbl, CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmFileEmbed path]))
+
+
+-- | Build a data-segment data block
+mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
mkDataLits section lbl lits
- = CmmData section (RawCmmStatics lbl $ map CmmStaticLit lits)
+ = CmmData section (CmmStaticsRaw lbl $ map CmmStaticLit lits)
-mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl RawCmmStatics info stmt
+mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
-- Build a read-only data block
mkRODataLits lbl lits
= mkDataLits section lbl lits
=====================================
compiler/GHC/CmmToAsm/PPC/CodeGen.hs
=====================================
@@ -669,7 +669,7 @@ getRegister' dflags _ (CmmLit (CmmFloat f frep)) = do
let format = floatFormat frep
code dst =
LDATA (Section ReadOnlyData lbl)
- (RawCmmStatics lbl [CmmStaticLit (CmmFloat f frep)])
+ (CmmStaticsRaw lbl [CmmStaticLit (CmmFloat f frep)])
`consOL` (addr_code `snocOL` LD format dst addr)
return (Any format code)
@@ -689,7 +689,7 @@ getRegister' dflags platform (CmmLit lit)
let rep = cmmLitType platform lit
format = cmmTypeFormat rep
code dst =
- LDATA (Section ReadOnlyData lbl) (RawCmmStatics lbl [CmmStaticLit lit])
+ LDATA (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmStaticLit lit])
`consOL` (addr_code `snocOL` LD format dst addr)
return (Any format code)
@@ -2110,7 +2110,7 @@ generateJumpTableForInstr config (BCTR ids (Just lbl) _) =
= CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0
(ncgWordWidth config))
where blockLabel = blockLbl blockid
- in Just (CmmData (Section ReadOnlyData lbl) (RawCmmStatics lbl jumpTable))
+ in Just (CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl jumpTable))
generateJumpTableForInstr _ _ = Nothing
-- -----------------------------------------------------------------------------
@@ -2340,7 +2340,7 @@ coerceInt2FP' ArchPPC fromRep toRep x = do
Amode addr addr_code <- getAmode D dynRef
let
code' dst = code `appOL` maybe_exts `appOL` toOL [
- LDATA (Section ReadOnlyData lbl) $ RawCmmStatics lbl
+ LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl
[CmmStaticLit (CmmInt 0x43300000 W32),
CmmStaticLit (CmmInt 0x80000000 W32)],
XORIS itmp src (ImmInt 0x8000),
=====================================
compiler/GHC/CmmToAsm/PPC/Ppr.hs
=====================================
@@ -61,7 +61,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
-- so label needed
vcat (map (pprBasicBlock platform top_info) blocks)
- Just (RawCmmStatics info_lbl _) ->
+ Just (CmmStaticsRaw info_lbl _) ->
pprSectionAlign config (Section Text info_lbl) $$
(if platformHasSubsectionsViaSymbols platform
then ppr (mkDeadStripPreventer info_lbl) <> char ':'
@@ -113,7 +113,7 @@ pprBasicBlock platform info_env (BasicBlock blockid instrs)
where
maybe_infotable = case mapLookup blockid info_env of
Nothing -> empty
- Just (RawCmmStatics info_lbl info) ->
+ Just (CmmStaticsRaw info_lbl info) ->
pprAlignForSection platform Text $$
vcat (map (pprData platform) info) $$
pprLabel platform info_lbl
@@ -122,7 +122,7 @@ pprBasicBlock platform info_env (BasicBlock blockid instrs)
pprDatas :: Platform -> RawCmmStatics -> SDoc
-- See note [emit-time elimination of static indirections] in CLabel.
-pprDatas _platform (RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
+pprDatas _platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
| lbl == mkIndStaticInfoLabel
, let labelInd (CmmLabelOff l _) = Just l
labelInd (CmmLabel l) = Just l
@@ -131,11 +131,12 @@ pprDatas _platform (RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticL
, alias `mayRedirectTo` ind'
= pprGloblDecl alias
$$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')
-pprDatas platform (RawCmmStatics lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats)
+pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats)
pprData :: Platform -> CmmStatic -> SDoc
pprData platform d = case d of
- CmmString str -> pprBytes str
+ CmmString str -> pprString str
+ CmmFileEmbed path -> pprFileEmbed path
CmmUninitialised bytes -> text ".space " <> int bytes
CmmStaticLit lit -> pprDataItem platform lit
=====================================
compiler/GHC/CmmToAsm/PPC/RegInfo.hs
=====================================
@@ -48,8 +48,8 @@ shortcutJump _ other = other
-- Here because it knows about JumpDest
shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics
-shortcutStatics fn (RawCmmStatics lbl statics)
- = RawCmmStatics lbl $ map (shortcutStatic fn) statics
+shortcutStatics fn (CmmStaticsRaw lbl statics)
+ = CmmStaticsRaw lbl $ map (shortcutStatic fn) statics
-- we need to get the jump tables, so apply the mapping to the entries
-- of a CmmData too.
=====================================
compiler/GHC/CmmToAsm/Ppr.hs
=====================================
@@ -14,7 +14,8 @@ module GHC.CmmToAsm.Ppr (
floatToBytes,
doubleToBytes,
pprASCII,
- pprBytes,
+ pprString,
+ pprFileEmbed,
pprSectionHeader
)
@@ -26,11 +27,9 @@ import AsmUtils
import GHC.Cmm.CLabel
import GHC.Cmm
import GHC.CmmToAsm.Config
-import GHC.Driver.Session
import FastString
import Outputable
import GHC.Platform
-import FileCleanup
import qualified Data.Array.Unsafe as U ( castSTUArray )
import Data.Array.ST
@@ -43,7 +42,6 @@ import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import GHC.Exts
import GHC.Word
-import System.IO.Unsafe
@@ -129,24 +127,18 @@ pprASCII str
]
ord0 = 0x30 -- = ord '0'
--- | Pretty print binary data.
---
--- Use either the ".string" directive or a ".incbin" directive.
--- See Note [Embedding large binary blobs]
+-- | Emit a ".string" directive
+pprString :: ByteString -> SDoc
+pprString bs = text "\t.string " <> doubleQuotes (pprASCII bs)
+
+-- | Emit a ".incbin" directive
--
-- A NULL byte is added after the binary data.
---
-pprBytes :: ByteString -> SDoc
-pprBytes bs = sdocWithDynFlags $ \dflags ->
- if binBlobThreshold dflags == 0
- || fromIntegral (BS.length bs) <= binBlobThreshold dflags
- then text "\t.string " <> doubleQuotes (pprASCII bs)
- else unsafePerformIO $ do
- bFile <- newTempName dflags TFL_CurrentModule ".dat"
- BS.writeFile bFile bs
- return $ text "\t.incbin "
- <> pprFilePathString bFile -- proper escape (see #16389)
- <> text "\n\t.byte 0"
+pprFileEmbed :: FilePath -> SDoc
+pprFileEmbed path
+ = text "\t.incbin "
+ <> pprFilePathString path -- proper escape (see #16389)
+ <> text "\n\t.byte 0"
{-
Note [Embedding large binary blobs]
=====================================
compiler/GHC/CmmToAsm/SPARC/CodeGen.hs
=====================================
@@ -342,7 +342,7 @@ generateJumpTableForInstr :: Platform -> Instr
-> Maybe (NatCmmDecl RawCmmStatics Instr)
generateJumpTableForInstr platform (JMP_TBL _ ids label) =
let jumpTable = map (jumpTableEntry platform) ids
- in Just (CmmData (Section ReadOnlyData label) (RawCmmStatics label jumpTable))
+ in Just (CmmData (Section ReadOnlyData label) (CmmStaticsRaw label jumpTable))
generateJumpTableForInstr _ _ = Nothing
=====================================
compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs
=====================================
@@ -86,7 +86,7 @@ getRegister (CmmLit (CmmFloat f W32)) = do
let code dst = toOL [
-- the data area
- LDATA (Section ReadOnlyData lbl) $ RawCmmStatics lbl
+ LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl
[CmmStaticLit (CmmFloat f W32)],
-- load the literal
@@ -99,7 +99,7 @@ getRegister (CmmLit (CmmFloat d W64)) = do
lbl <- getNewLabelNat
tmp <- getNewRegNat II32
let code dst = toOL [
- LDATA (Section ReadOnlyData lbl) $ RawCmmStatics lbl
+ LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl
[CmmStaticLit (CmmFloat d W64)],
SETHI (HI (ImmCLbl lbl)) tmp,
LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
=====================================
compiler/GHC/CmmToAsm/SPARC/Ppr.hs
=====================================
@@ -67,7 +67,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed
vcat (map (pprBasicBlock platform top_info) blocks)
- Just (RawCmmStatics info_lbl _) ->
+ Just (CmmStaticsRaw info_lbl _) ->
(if platformHasSubsectionsViaSymbols platform
then pprSectionAlign config dspSection $$
ppr (mkDeadStripPreventer info_lbl) <> char ':'
@@ -96,7 +96,7 @@ pprBasicBlock platform info_env (BasicBlock blockid instrs)
where
maybe_infotable = case mapLookup blockid info_env of
Nothing -> empty
- Just (RawCmmStatics info_lbl info) ->
+ Just (CmmStaticsRaw info_lbl info) ->
pprAlignForSection Text $$
vcat (map (pprData platform) info) $$
pprLabel platform info_lbl
@@ -104,7 +104,7 @@ pprBasicBlock platform info_env (BasicBlock blockid instrs)
pprDatas :: Platform -> RawCmmStatics -> SDoc
-- See note [emit-time elimination of static indirections] in CLabel.
-pprDatas _platform (RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
+pprDatas _platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
| lbl == mkIndStaticInfoLabel
, let labelInd (CmmLabelOff l _) = Just l
labelInd (CmmLabel l) = Just l
@@ -113,12 +113,14 @@ pprDatas _platform (RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticL
, alias `mayRedirectTo` ind'
= pprGloblDecl alias
$$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')
-pprDatas platform (RawCmmStatics lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats)
+pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats)
pprData :: Platform -> CmmStatic -> SDoc
-pprData _ (CmmString str) = pprBytes str
-pprData _ (CmmUninitialised bytes) = text ".skip " <> int bytes
-pprData platform (CmmStaticLit lit) = pprDataItem platform lit
+pprData platform d = case d of
+ CmmString str -> pprString str
+ CmmFileEmbed path -> pprFileEmbed path
+ CmmUninitialised bytes -> text ".skip " <> int bytes
+ CmmStaticLit lit -> pprDataItem platform lit
pprGloblDecl :: CLabel -> SDoc
pprGloblDecl lbl
=====================================
compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs
=====================================
@@ -44,8 +44,8 @@ shortcutJump _ other = other
shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics
-shortcutStatics fn (RawCmmStatics lbl statics)
- = RawCmmStatics lbl $ map (shortcutStatic fn) statics
+shortcutStatics fn (CmmStaticsRaw lbl statics)
+ = CmmStaticsRaw lbl $ map (shortcutStatic fn) statics
-- we need to get the jump tables, so apply the mapping to the entries
-- of a CmmData too.
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -1485,7 +1485,7 @@ memConstant align lit = do
return (addr, addr_code)
else return (ripRel (ImmCLbl lbl), nilOL)
let code =
- LDATA rosection (align, RawCmmStatics lbl [CmmStaticLit lit])
+ LDATA rosection (align, CmmStaticsRaw lbl [CmmStaticLit lit])
`consOL` addr_code
return (Amode addr code)
@@ -3329,7 +3329,7 @@ createJumpTable config ids section lbl
where blockLabel = blockLbl blockid
in map jumpTableEntryRel ids
| otherwise = map (jumpTableEntry config) ids
- in CmmData section (mkAlignment 1, RawCmmStatics lbl jumpTable)
+ in CmmData section (mkAlignment 1, CmmStaticsRaw lbl jumpTable)
extractUnwindPoints :: [Instr] -> [UnwindPoint]
extractUnwindPoints instrs =
=====================================
compiler/GHC/CmmToAsm/X86/Instr.hs
=====================================
@@ -1021,8 +1021,8 @@ shortcutJump fn insn = shortcutJump' fn (setEmpty :: LabelSet) insn
-- Here because it knows about JumpDest
shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, RawCmmStatics) -> (Alignment, RawCmmStatics)
-shortcutStatics fn (align, RawCmmStatics lbl statics)
- = (align, RawCmmStatics lbl $ map (shortcutStatic fn) statics)
+shortcutStatics fn (align, CmmStaticsRaw lbl statics)
+ = (align, CmmStaticsRaw lbl $ map (shortcutStatic fn) statics)
-- we need to get the jump tables, so apply the mapping to the entries
-- of a CmmData too.
=====================================
compiler/GHC/CmmToAsm/X86/Ppr.hs
=====================================
@@ -93,7 +93,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$
pprSizeDecl platform lbl
- Just (RawCmmStatics info_lbl _) ->
+ Just (CmmStaticsRaw info_lbl _) ->
pprSectionAlign config (Section Text info_lbl) $$
pprProcAlignment config $$
(if platformHasSubsectionsViaSymbols platform
@@ -132,7 +132,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
platform = ncgPlatform config
maybe_infotable c = case mapLookup blockid info_env of
Nothing -> c
- Just (RawCmmStatics infoLbl info) ->
+ Just (CmmStaticsRaw infoLbl info) ->
pprAlignForSection platform Text $$
infoTableLoc $$
vcat (map (pprData config) info) $$
@@ -151,7 +151,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
pprDatas :: NCGConfig -> (Alignment, RawCmmStatics) -> SDoc
-- See note [emit-time elimination of static indirections] in CLabel.
-pprDatas _config (_, RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
+pprDatas _config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
| lbl == mkIndStaticInfoLabel
, let labelInd (CmmLabelOff l _) = Just l
labelInd (CmmLabel l) = Just l
@@ -161,13 +161,14 @@ pprDatas _config (_, RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStatic
= pprGloblDecl alias
$$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')
-pprDatas config (align, (RawCmmStatics lbl dats))
+pprDatas config (align, (CmmStaticsRaw lbl dats))
= vcat (pprAlign platform align : pprLabel platform lbl : map (pprData config) dats)
where
platform = ncgPlatform config
pprData :: NCGConfig -> CmmStatic -> SDoc
-pprData _config (CmmString str) = pprBytes str
+pprData _config (CmmString str) = pprString str
+pprData _config (CmmFileEmbed path) = pprFileEmbed path
pprData config (CmmUninitialised bytes)
= let platform = ncgPlatform config
=====================================
compiler/GHC/CmmToC.hs
=====================================
@@ -88,7 +88,7 @@ pprTop dflags = \case
(CmmProc infos clbl _in_live_regs graph) ->
(case mapLookup (g_entry graph) infos of
Nothing -> empty
- Just (RawCmmStatics info_clbl info_dat) ->
+ Just (CmmStaticsRaw info_clbl info_dat) ->
pprDataExterns platform info_dat $$
pprWordArray dflags info_is_in_rodata info_clbl info_dat) $$
(vcat [
@@ -111,21 +111,21 @@ pprTop dflags = \case
-- We only handle (a) arrays of word-sized things and (b) strings.
- (CmmData section (RawCmmStatics lbl [CmmString str])) ->
+ (CmmData section (CmmStaticsRaw lbl [CmmString str])) ->
pprExternDecl platform lbl $$
hcat [
pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
text "[] = ", pprStringInCStyle str, semi
]
- (CmmData section (RawCmmStatics lbl [CmmUninitialised size])) ->
+ (CmmData section (CmmStaticsRaw lbl [CmmUninitialised size])) ->
pprExternDecl platform lbl $$
hcat [
pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
brackets (int size), semi
]
- (CmmData section (RawCmmStatics lbl lits)) ->
+ (CmmData section (CmmStaticsRaw lbl lits)) ->
pprDataExterns platform lits $$
pprWordArray dflags (isSecConstant section) lbl lits
where
@@ -574,6 +574,7 @@ pprStatic dflags s = case s of
-- these should be inlined, like the old .hc
CmmString s' -> nest 4 (mkW_ <> parens(pprStringInCStyle s'))
+ CmmFileEmbed {} -> panic "Unexpected CmmFileEmbed literal"
-- ---------------------------------------------------------------------------
=====================================
compiler/GHC/CmmToLlvm.hs
=====================================
@@ -121,9 +121,9 @@ llvmGroupLlvmGens cmm = do
let split (CmmData s d' ) = return $ Just (s, d')
split (CmmProc h l live g) = do
-- Set function type
- let l' = case mapLookup (g_entry g) h of
+ let l' = case mapLookup (g_entry g) h :: Maybe RawCmmStatics of
Nothing -> l
- Just (RawCmmStatics info_lbl _) -> info_lbl
+ Just (CmmStaticsRaw info_lbl _) -> info_lbl
lml <- strCLabel_llvm l'
funInsert lml =<< llvmFunTy live
return Nothing
=====================================
compiler/GHC/CmmToLlvm/Data.hs
=====================================
@@ -44,7 +44,7 @@ linkage lbl = if externallyVisibleCLabel lbl
-- | Pass a CmmStatic section to an equivalent Llvm code.
genLlvmData :: (Section, RawCmmStatics) -> LlvmM LlvmData
-- See note [emit-time elimination of static indirections] in CLabel.
-genLlvmData (_, RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
+genLlvmData (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
| lbl == mkIndStaticInfoLabel
, let labelInd (CmmLabelOff l _) = Just l
labelInd (CmmLabel l) = Just l
@@ -67,7 +67,7 @@ genLlvmData (_, RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit i
pure ([LMGlobal aliasDef $ Just orig], [tyAlias])
-genLlvmData (sec, RawCmmStatics lbl xs) = do
+genLlvmData (sec, CmmStaticsRaw lbl xs) = do
label <- strCLabel_llvm lbl
static <- mapM genData xs
lmsec <- llvmSection sec
@@ -132,6 +132,7 @@ llvmSection (Section t suffix) = do
-- | Handle static data
genData :: CmmStatic -> LlvmM LlvmStatic
+genData (CmmFileEmbed {}) = panic "Unexpected CmmFileEmbed literal"
genData (CmmString str) = do
let v = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8)
(BS.unpack str)
=====================================
compiler/GHC/CmmToLlvm/Ppr.hs
=====================================
@@ -46,7 +46,7 @@ pprLlvmCmmDecl (CmmData _ lmdata)
pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
= do let lbl = case mb_info of
Nothing -> entry_lbl
- Just (RawCmmStatics info_lbl _) -> info_lbl
+ Just (CmmStaticsRaw info_lbl _) -> info_lbl
link = if externallyVisibleCLabel lbl
then ExternallyVisible
else Internal
@@ -63,7 +63,7 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
-- generate the info table
prefix <- case mb_info of
Nothing -> return Nothing
- Just (RawCmmStatics _ statics) -> do
+ Just (CmmStaticsRaw _ statics) -> do
infoStatics <- mapM genData statics
let infoTy = LMStruct $ map getStatType infoStatics
return $ Just $ LMStaticStruc infoStatics infoTy
=====================================
compiler/GHC/StgToCmm.hs
=====================================
@@ -27,6 +27,7 @@ import GHC.StgToCmm.Hpc
import GHC.StgToCmm.Ticky
import GHC.Cmm
+import GHC.Cmm.Utils
import GHC.Cmm.CLabel
import GHC.Stg.Syntax
@@ -45,6 +46,7 @@ import Outputable
import Stream
import GHC.Types.Basic
import GHC.Types.Var.Set ( isEmptyDVarSet )
+import FileCleanup
import OrdList
import GHC.Cmm.Graph
@@ -52,6 +54,8 @@ import GHC.Cmm.Graph
import Data.IORef
import Control.Monad (when,void)
import Util
+import System.IO.Unsafe
+import qualified Data.ByteString as BS
codeGen :: DynFlags
-> Module
@@ -133,12 +137,24 @@ cgTopBinding dflags (StgTopLifted (StgRec pairs))
; sequence_ fcodes
}
-cgTopBinding dflags (StgTopStringLit id str)
- = do { let label = mkBytesLabel (idName id)
- ; let (lit, decl) = mkByteStringCLit label str
- ; emitDecl decl
- ; addBindC (litIdInfo dflags id mkLFStringLit lit)
- }
+cgTopBinding dflags (StgTopStringLit id str) = do
+ let label = mkBytesLabel (idName id)
+ -- emit either a CmmString literal or dump the string in a file and emit a
+ -- CmmFileEmbed literal.
+ -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr
+ let isNCG = platformMisc_ghcWithNativeCodeGen $ platformMisc dflags
+ isSmall = fromIntegral (BS.length str) <= binBlobThreshold dflags
+ asString = binBlobThreshold dflags == 0 || isSmall
+
+ (lit,decl) = if not isNCG || asString
+ then mkByteStringCLit label str
+ else mkFileEmbedLit label $ unsafePerformIO $ do
+ bFile <- newTempName dflags TFL_CurrentModule ".dat"
+ BS.writeFile bFile str
+ return bFile
+ emitDecl decl
+ addBindC (litIdInfo dflags id mkLFStringLit lit)
+
cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
-- The Id is passed along for setting up a binding...
@@ -177,7 +193,7 @@ mkModuleInit cost_centre_info this_mod hpc_info
cgEnumerationTyCon :: TyCon -> FCode ()
cgEnumerationTyCon tycon
= do dflags <- getDynFlags
- emitRawRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
+ emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
[ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)
(tagForCon dflags con)
| con <- tyConDataCons tycon]
=====================================
compiler/GHC/StgToCmm/Hpc.hs
=====================================
@@ -35,15 +35,15 @@ mkTickBox platform mod n
(CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
n
+-- | Emit top-level tables for HPC and return code to initialise
initHpc :: Module -> HpcInfo -> FCode ()
--- Emit top-level tables for HPC and return code to initialise
initHpc _ (NoHpcInfo {})
= return ()
initHpc this_mod (HpcInfo tickCount _hashNo)
= do dflags <- getDynFlags
when (gopt Opt_Hpc dflags) $
- emitRawDataLits (mkHpcTicksLabel this_mod)
- [ (CmmInt 0 W64)
- | _ <- take tickCount [0 :: Int ..]
- ]
+ emitDataLits (mkHpcTicksLabel this_mod)
+ [ (CmmInt 0 W64)
+ | _ <- take tickCount [0 :: Int ..]
+ ]
=====================================
compiler/GHC/StgToCmm/Prof.hs
=====================================
@@ -236,7 +236,7 @@ emitCostCentreDecl cc = do
is_caf, -- StgInt is_caf
zero platform -- struct _CostCentre *link
]
- ; emitRawDataLits (mkCCLabel cc) lits
+ ; emitDataLits (mkCCLabel cc) lits
}
emitCostCentreStackDecl :: CostCentreStack -> FCode ()
@@ -253,7 +253,7 @@ emitCostCentreStackDecl ccs
-- layouts of structs containing long-longs, simply
-- pad out the struct with zero words until we hit the
-- size of the overall struct (which we get via DerivedConstants.h)
- emitRawDataLits (mkCCSLabel ccs) (mk_lits cc)
+ emitDataLits (mkCCSLabel ccs) (mk_lits cc)
Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
zero :: Platform -> CmmLit
=====================================
compiler/GHC/StgToCmm/Ticky.hs
=====================================
@@ -243,7 +243,7 @@ emitTickyCounter cloType name args
; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name
; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args
- ; emitRawDataLits ctr_lbl
+ ; emitDataLits ctr_lbl
-- Must match layout of includes/rts/Ticky.h's StgEntCounter
--
-- krc: note that all the fields are I32 now; some were I16
@@ -256,7 +256,7 @@ emitTickyCounter cloType name args
arg_descr_lit,
zeroCLit platform, -- Entries into this thing
zeroCLit platform, -- Heap allocated by this thing
- zeroCLit platform -- Link to next StgEntCounter
+ zeroCLit platform -- Link to next StgEntCounter
]
}
=====================================
compiler/GHC/StgToCmm/Utils.hs
=====================================
@@ -11,8 +11,7 @@
module GHC.StgToCmm.Utils (
cgLit, mkSimpleLit,
- emitRawDataLits, mkRawDataLits,
- emitRawRODataLits, mkRawRODataLits,
+ emitDataLits, emitRODataLits,
emitDataCon,
emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
assignTemp, newTemp,
@@ -38,7 +37,6 @@ module GHC.StgToCmm.Utils (
cmmUntag, cmmIsTagged,
addToMem, addToMemE, addToMemLblE, addToMemLbl,
- mkWordCLit, mkByteStringCLit,
newStringCLit, newByteStringCLit,
blankWord,
@@ -60,7 +58,7 @@ import GHC.Cmm.BlockId
import GHC.Cmm.Graph as CmmGraph
import GHC.Platform.Regs
import GHC.Cmm.CLabel
-import GHC.Cmm.Utils hiding (mkDataLits, mkRODataLits, mkByteStringCLit)
+import GHC.Cmm.Utils
import GHC.Cmm.Switch
import GHC.StgToCmm.CgUtils
@@ -83,7 +81,6 @@ import GHC.Types.CostCentre
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS8
-import qualified Data.ByteString as BS
import qualified Data.Map as M
import Data.Char
import Data.List
@@ -276,40 +273,13 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load)
--
-------------------------------------------------------------------------
-mkRawDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
--- Build a data-segment data block
-mkRawDataLits section lbl lits
- = CmmData section (CmmStaticsRaw lbl (map CmmStaticLit lits))
+-- | Emit a data-segment data block
+emitDataLits :: CLabel -> [CmmLit] -> FCode ()
+emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)
-mkRawRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
--- Build a read-only data block
-mkRawRODataLits lbl lits
- = mkRawDataLits section lbl lits
- where
- section | any needsRelocation lits = Section RelocatableReadOnlyData lbl
- | otherwise = Section ReadOnlyData lbl
- needsRelocation (CmmLabel _) = True
- needsRelocation (CmmLabelOff _ _) = True
- needsRelocation _ = False
-
-mkByteStringCLit
- :: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt)
--- We have to make a top-level decl for the string,
--- and return a literal pointing to it
-mkByteStringCLit lbl bytes
- = (CmmLabel lbl, CmmData (Section sec lbl) (CmmStaticsRaw lbl [CmmString bytes]))
- where
- -- This can not happen for String literals (as there \NUL is replaced by
- -- C0 80). However, it can happen with Addr# literals.
- sec = if 0 `BS.elem` bytes then ReadOnlyData else CString
-
-emitRawDataLits :: CLabel -> [CmmLit] -> FCode ()
--- Emit a data-segment data block
-emitRawDataLits lbl lits = emitDecl (mkRawDataLits (Section Data lbl) lbl lits)
-
-emitRawRODataLits :: CLabel -> [CmmLit] -> FCode ()
--- Emit a read-only data block
-emitRawRODataLits lbl lits = emitDecl (mkRawRODataLits lbl lits)
+-- | Emit a read-only data block
+emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
+emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)
emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode ()
emitDataCon lbl itbl ccs payload = emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload))
=====================================
testsuite/tests/perf/compiler/all.T
=====================================
@@ -355,7 +355,7 @@ test ('WWRec',
['-v0 -O'])
test('T16190',
- [req_th, collect_stats()],
+ [req_th, collect_compiler_stats()],
multimod_compile,
['T16190.hs', '-v0'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a214d2142c1bafa71fe52cb3823351ff9322d336...cc2918a0407e1581e824ebd90a1fcbb0637d5744
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a214d2142c1bafa71fe52cb3823351ff9322d336...cc2918a0407e1581e824ebd90a1fcbb0637d5744
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/20200403/db4e268d/attachment-0001.html>
More information about the ghc-commits
mailing list