Reduce the size of string literals in binaries.

Removed the alignment for strings and mark then as cstring sections in
the generated asm so the linker can merge duplicate sections.

Reviewers: rwbarton, trofi, austin, trommler, simonmar, hvr, bgamari

Reviewed By: hvr, bgamari

Subscribers: simonpj, hvr, thomie

Differential Revision: https://phabricator.haskell.org/D1290

GHC Trac Issues: #9577

compiler/cmm/CLabel.hs

@@ -1088,6 +1088,10 @@ pprCLabel platform (DeadStripPreventer lbl)
  | cGhcWithNativeCodeGen == "YES"
    = pprCLabel platform lbl <> text "_dsp"
 
+pprCLabel _ (StringLitLabel u)
+ | cGhcWithNativeCodeGen == "YES"
+  = pprUnique u <> ptext (sLit "_str")
+
 pprCLabel platform lbl
    = getPprStyle $ \ sty ->
      if cGhcWithNativeCodeGen == "YES" && asmStyle sty
@@ -1109,8 +1113,8 @@ pprAsmCLbl _ lbl
    = pprCLbl lbl
 
 pprCLbl :: CLabel -> SDoc
-pprCLbl (StringLitLabel u)
-  = pprUnique u <> text "_str"
+pprCLbl (StringLitLabel _)
+  = panic "pprCLbl StringLitLabel"
 
 pprCLbl (CaseLabel u CaseReturnPt)
   = hcat [pprUnique u, text "_ret"]

compiler/cmm/Cmm.hs

@@ -172,6 +172,7 @@ data SectionType
   | RelocatableReadOnlyData
   | UninitialisedData
   | ReadOnlyData16      -- .rodata.cst16 on x86_64, 16-byte aligned
+  | CString
   | OtherSection String
   deriving (Show)
 

compiler/cmm/CmmUtils.hs

@@ -171,10 +171,13 @@ mkByteStringCLit :: Unique -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stm
 -- We have to make a top-level decl for the string,
 -- and return a literal pointing to it
 mkByteStringCLit uniq bytes
-  = (CmmLabel lbl, CmmData sec $ Statics lbl [CmmString bytes])
+  = (CmmLabel lbl, CmmData (Section sec lbl)  $ Statics lbl [CmmString bytes])
   where
     lbl = mkStringLitLabel uniq
-    sec = Section ReadOnlyData lbl
+    -- 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 `elem` bytes then ReadOnlyData else CString
+
 mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
 -- Build a data-segment data block
 mkDataLits section lbl lits

compiler/cmm/PprCmmDecl.hs

@@ -170,4 +170,5 @@ pprSectionType s = doubleQuotes (ptext t)
     RelocatableReadOnlyData
                       -> sLit "relreadonly"
     UninitialisedData -> sLit "uninitialised"
+    CString           -> sLit "cstring"
     OtherSection s'   -> sLit s' -- Not actually a literal though.

compiler/llvmGen/LlvmCodeGen/Data.hs

@@ -59,6 +59,7 @@ isSecConstant (Section t _) = case t of
     ReadOnlyData            -> True
     RelocatableReadOnlyData -> True
     ReadOnlyData16          -> True
+    CString                 -> True
     Data                    -> False
     UninitialisedData       -> False
     (OtherSection _)        -> False
@@ -72,6 +73,7 @@ llvmSectionType t = case t of
     ReadOnlyData16          -> fsLit ".rodata.cst16"
     Data                    -> fsLit ".data"
     UninitialisedData       -> fsLit ".bss"
+    CString                 -> fsLit ".cstring"
     (OtherSection _)        -> panic "llvmSectionType: unknown section type"
 
 -- | Format a Cmm Section into a LLVM section name

compiler/nativeGen/PPC/Ppr.hs

@@ -348,6 +348,12 @@ pprAlignForSection seg =
        ReadOnlyData16
         | osDarwin       -> sLit ".align 4"
         | otherwise      -> sLit ".align 4"
+       -- TODO: This is copied from the ReadOnlyData case, but it can likely be
+       -- made more efficient.
+       CString
+        | osDarwin       -> sLit ".align 2"
+        | ppc64          -> sLit ".align 3"
+        | otherwise      -> sLit ".align 2"
        OtherSection _    -> panic "PprMach.pprSectionAlign: unknown section"
 
 pprDataItem :: CmmLit -> SDoc

compiler/nativeGen/PprBase.hs

@@ -107,6 +107,7 @@ pprGNUSectionHeader t suffix = sdocWithDynFlags $ \dflags ->
       RelocatableReadOnlyData -> sLit ".data.rel.ro"
       UninitialisedData -> sLit ".bss"
       ReadOnlyData16 -> sLit ".rodata.cst16"
+      CString -> sLit ".rodata.str1.1,\"aMS\",@progbits,1"
       OtherSection _ ->
         panic "PprBase.pprGNUSectionHeader: unknown section type"
 
@@ -119,6 +120,7 @@ pprXcoffSectionHeader t = text $ case t of
      ReadOnlyData            -> ".csect .text[PR] # ReadOnlyData"
      RelocatableReadOnlyData -> ".csect .text[PR] # RelocatableReadOnlyData"
      ReadOnlyData16          -> ".csect .text[PR] # ReadOnlyData16"
+     CString                 -> ".csect .text[PR] # CString"
      UninitialisedData       -> ".csect .data[BS]"
      OtherSection _          ->
        panic "PprBase.pprXcoffSectionHeader: unknown section type"
@@ -132,5 +134,6 @@ pprDarwinSectionHeader t =
      RelocatableReadOnlyData -> sLit ".const_data"
      UninitialisedData -> sLit ".data"
      ReadOnlyData16 -> sLit ".const"
+     CString -> sLit ".section\t__TEXT,__cstring,cstring_literals"
      OtherSection _ ->
        panic "PprBase.pprDarwinSectionHeader: unknown section type"

compiler/nativeGen/SPARC/Ppr.hs

@@ -339,6 +339,9 @@ pprAlignForSection seg =
                         -> sLit ".align 8"
       UninitialisedData -> sLit ".align 8"
       ReadOnlyData16    -> sLit ".align 16"
+      -- TODO: This is copied from the ReadOnlyData case, but it can likely be
+      -- made more efficient.
+      CString           -> sLit ".align 8"
       OtherSection _    -> panic "PprMach.pprSectionHeader: unknown section")
 
 -- | Pretty print a data item.

compiler/nativeGen/X86/Ppr.hs

@@ -44,6 +44,8 @@ import Outputable
 
 import Data.Word
 
+import Data.Char
+
 import Data.Bits
 
 -- -----------------------------------------------------------------------------
@@ -140,10 +142,10 @@ pprBasicBlock info_env (BasicBlock blockid instrs)
 pprDatas :: (Alignment, CmmStatics) -> SDoc
 pprDatas (align, (Statics lbl dats))
  = vcat (pprAlign align : pprLabel lbl : map pprData dats)
- -- TODO: could remove if align == 1
 
 pprData :: CmmStatic -> SDoc
-pprData (CmmString str) = pprASCII str
+pprData (CmmString str)
+ = ptext (sLit "\t.asciz ") <> doubleQuotes (pprASCII str)
 
 pprData (CmmUninitialised bytes)
  = sdocWithPlatform $ \platform ->
@@ -172,10 +174,20 @@ pprLabel lbl = pprGloblDecl lbl
 
 pprASCII :: [Word8] -> SDoc
 pprASCII str
-  = vcat (map do1 str) $$ do1 0
+  = hcat (map (do1 . fromIntegral) str)
     where
-       do1 :: Word8 -> SDoc
-       do1 w = text "\t.byte\t" <> int (fromIntegral w)
+       do1 :: Int -> SDoc
+       do1 w | '\t' <- chr w = ptext (sLit "\\t")
+       do1 w | '\n' <- chr w = ptext (sLit "\\n")
+       do1 w | '"'  <- chr w = ptext (sLit "\\\"")
+       do1 w | '\\' <- chr w = ptext (sLit "\\\\")
+       do1 w | isPrint (chr w) = char (chr w)
+       do1 w | otherwise = char '\\' <> octal w
+
+       octal :: Int -> SDoc
+       octal w = int ((w `div` 64) `mod` 8)
+                  <> int ((w `div` 8) `mod` 8)
+                  <> int (w `mod` 8)
 
 pprAlign :: Int -> SDoc
 pprAlign bytes
@@ -418,10 +430,12 @@ pprAlignForSection seg =
        | target32Bit platform ->
           case seg of
            ReadOnlyData16    -> int 4
+           CString           -> int 1
            _                 -> int 2
        | otherwise ->
           case seg of
            ReadOnlyData16    -> int 4
+           CString           -> int 1
            _                 -> int 3
       -- Other: alignments are given as bytes.
       _
@@ -429,10 +443,12 @@ pprAlignForSection seg =
           case seg of
            Text              -> text "4,0x90"
            ReadOnlyData16    -> int 16
+           CString           -> int 1
            _                 -> int 4
        | otherwise ->
           case seg of
            ReadOnlyData16    -> int 16
+           CString           -> int 1
            _                 -> int 8
 
 pprDataItem :: CmmLit -> SDoc

testsuite/tests/codeGen/should_run/T9577.hs

+{-# LANGUAGE MagicHash #-}
+
+import T9577_A
+
+import GHC.Exts (Ptr(..), Addr#)
+
+main = print (foo == Ptr "foo"#)

testsuite/tests/codeGen/should_run/T9577.stdout

+True

testsuite/tests/codeGen/should_run/T9577_A.hs

+{-# LANGUAGE MagicHash #-}
+
+
+module T9577_A where
+
+import GHC.Exts (Ptr(..), Addr#)
+
+foo = Ptr "foo"#

testsuite/tests/codeGen/should_run/all.T

@@ -148,3 +148,4 @@ test('T12059', normal, compile_and_run, [''])
 test('T12433', normal, compile_and_run, [''])
 test('T12757', normal, compile_and_run, [''])
 test('T12855', normal, compile_and_run, [''])
+test('T9577', [ unless(arch('x86_64') or arch('i386'),skip), only_ways(['normal']) ], compile_and_run, [''])