From 7e00046772e053c63ac93630a60b0f396e32a2d7 Mon Sep 17 00:00:00 2001
From: Sergei Trofimovich <slyfox@gentoo.org>
Date: Sun, 16 Apr 2017 10:43:38 +0100
Subject: [PATCH] compiler/cmm/PprC.hs: constify labels in .rodata

Summary:
Consider one-line module
    module B (v) where v = "hello"
in -fvia-C mode it generates code like
    static char gibberish_str[] = "hello";

It resides in data section (precious resource on ia64!).
The patch switches genrator to emit:
    static const char gibberish_str[] = "hello";

Other types if symbols that gained 'const' qualifier are:

- info tables (from haskell and CMM)
- static reference tables (from haskell and CMM)

Cleanups along the way:

- fixed info tables defined in .cmm to reside in .rodata
- split out closure declaration into 'IC_' / 'EC_'
- added label declaration (based on label type) right before
  each label definition (based on section type) so that C
  compiler could check if declaration and definition matches
  at definition site.

Signed-off-by: Sergei Trofimovich <slyfox@gentoo.org>

Test Plan: ran testsuite on unregisterised x86_64 compiler

Reviewers: simonmar, ezyang, austin, bgamari, erikd

Subscribers: rwbarton, thomie

GHC Trac Issues: #8996

Differential Revision: https://phabricator.haskell.org/D3481
---
 compiler/cmm/CLabel.hs               | 24 ++++++++++++++
 compiler/cmm/Cmm.hs                  | 13 ++++++++
 compiler/cmm/CmmInfo.hs              |  2 +-
 compiler/cmm/PprC.hs                 | 62 +++++++++++++++++++++++-------------
 compiler/llvmGen/LlvmCodeGen/Data.hs | 12 -------
 includes/Stg.h                       | 22 +++++++++----
 includes/rts/storage/InfoTables.h    |  2 +-
 includes/stg/MiscClosures.h          | 14 ++++----
 8 files changed, 102 insertions(+), 49 deletions(-)

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 3ba4f7647a..62c8037e9c 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -89,6 +89,8 @@ module CLabel (
         foreignLabelStdcallInfo,
         isBytesLabel,
         isForeignLabel,
+        isSomeRODataLabel,
+        isStaticClosureLabel,
         mkCCLabel, mkCCSLabel,
 
         DynamicLinkerLabelInfo(..),
@@ -575,6 +577,28 @@ isForeignLabel :: CLabel -> Bool
 isForeignLabel (ForeignLabel _ _ _ _) = True
 isForeignLabel _lbl = False
 
+-- | Whether label is a static closure label (can come from haskell or cmm)
+isStaticClosureLabel :: CLabel -> Bool
+-- Closure defined in haskell (.hs)
+isStaticClosureLabel (IdLabel _ _ Closure) = True
+-- Closure defined in cmm
+isStaticClosureLabel (CmmLabel _ _ CmmClosure) = True
+isStaticClosureLabel _lbl = False
+
+-- | Whether label is a .rodata label
+isSomeRODataLabel :: CLabel -> Bool
+-- info table defined in haskell (.hs)
+isSomeRODataLabel (IdLabel _ _ ClosureTable) = True
+isSomeRODataLabel (IdLabel _ _ ConInfoTable) = True
+isSomeRODataLabel (IdLabel _ _ InfoTable) = True
+isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True
+-- static reference tables defined in haskell (.hs)
+isSomeRODataLabel (IdLabel _ _ SRT) = True
+isSomeRODataLabel (SRTLabel _) = True
+-- info table defined in cmm (.cmm)
+isSomeRODataLabel (CmmLabel _ _ CmmInfo) = True
+isSomeRODataLabel _lbl = False
+
 -- | Get the label size field from a ForeignLabel
 foreignLabelStdcallInfo :: CLabel -> Maybe Int
 foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index d2ee531686..bab20f3fdd 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -9,6 +9,7 @@ module Cmm (
      CmmBlock,
      RawCmmDecl, RawCmmGroup,
      Section(..), SectionType(..), CmmStatics(..), CmmStatic(..),
+     isSecConstant,
 
      -- ** Blocks containing lists
      GenBasicBlock(..), blockId,
@@ -167,6 +168,18 @@ data SectionType
   | OtherSection String
   deriving (Show)
 
+-- | Should a data in this section be considered constant
+isSecConstant :: Section -> Bool
+isSecConstant (Section t _) = case t of
+    Text                    -> True
+    ReadOnlyData            -> True
+    RelocatableReadOnlyData -> True
+    ReadOnlyData16          -> True
+    CString                 -> True
+    Data                    -> False
+    UninitialisedData       -> False
+    (OtherSection _)        -> False
+
 data Section = Section SectionType CLabel
 
 data CmmStatic
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index b5e800a977..35e3a1888d 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -133,7 +133,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
         --
         return (top_decls ++
                 [CmmProc mapEmpty entry_lbl live blocks,
-                 mkDataLits (Section Data info_lbl) info_lbl
+                 mkRODataLits info_lbl
                     (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
 
   --
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 56de94079f..21ed6f6516 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -83,12 +83,13 @@ pprC tops = vcat $ intersperse blankLine $ map pprTop tops
 -- top level procs
 --
 pprTop :: RawCmmDecl -> SDoc
-pprTop (CmmProc infos clbl _ graph) =
+pprTop (CmmProc infos clbl _in_live_regs graph) =
 
     (case mapLookup (g_entry graph) infos of
        Nothing -> empty
-       Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$
-                                            pprWordArray info_clbl info_dat) $$
+       Just (Statics info_clbl info_dat) ->
+           pprDataExterns info_dat $$
+           pprWordArray info_is_in_rodata info_clbl info_dat) $$
     (vcat [
            blankLine,
            extern_decls,
@@ -99,6 +100,8 @@ pprTop (CmmProc infos clbl _ graph) =
            rbrace ]
     )
   where
+        -- info tables are always in .rodata
+        info_is_in_rodata = True
         blocks = toBlockListEntryFirst graph
         (temp_decls, extern_decls) = pprTempAndExternDecls blocks
 
@@ -107,21 +110,23 @@ pprTop (CmmProc infos clbl _ graph) =
 
 -- We only handle (a) arrays of word-sized things and (b) strings.
 
-pprTop (CmmData _section (Statics lbl [CmmString str])) =
+pprTop (CmmData section (Statics lbl [CmmString str])) =
+  pprExternDecl lbl $$
   hcat [
-    pprLocalness lbl, text "char ", ppr lbl,
+    pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
     text "[] = ", pprStringInCStyle str, semi
   ]
 
-pprTop (CmmData _section (Statics lbl [CmmUninitialised size])) =
+pprTop (CmmData section (Statics lbl [CmmUninitialised size])) =
+  pprExternDecl lbl $$
   hcat [
-    pprLocalness lbl, text "char ", ppr lbl,
+    pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
     brackets (int size), semi
   ]
 
-pprTop (CmmData _section (Statics lbl lits)) =
+pprTop (CmmData section (Statics lbl lits)) =
   pprDataExterns lits $$
-  pprWordArray lbl lits
+  pprWordArray (isSecConstant section) lbl lits
 
 -- --------------------------------------------------------------------------
 -- BasicBlocks are self-contained entities: they always end in a jump.
@@ -141,10 +146,12 @@ pprBBlock block =
 -- Info tables. Just arrays of words.
 -- See codeGen/ClosureInfo, and nativeGen/PprMach
 
-pprWordArray :: CLabel -> [CmmStatic] -> SDoc
-pprWordArray lbl ds
+pprWordArray :: Bool -> CLabel -> [CmmStatic] -> SDoc
+pprWordArray is_ro lbl ds
   = sdocWithDynFlags $ \dflags ->
-    hcat [ pprLocalness lbl, text "StgWord"
+    -- TODO: align closures only
+    pprExternDecl lbl $$
+    hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord"
          , space, ppr lbl, text "[]"
          -- See Note [StgWord alignment]
          , pprAlignment (wordWidth dflags)
@@ -180,6 +187,10 @@ pprLocalness :: CLabel -> SDoc
 pprLocalness lbl | not $ externallyVisibleCLabel lbl = text "static "
                  | otherwise = empty
 
+pprConstness :: Bool -> SDoc
+pprConstness is_ro | is_ro = text "const "
+                   | otherwise = empty
+
 -- --------------------------------------------------------------------------
 -- Statements.
 --
@@ -984,31 +995,38 @@ is_cishCC JavaScriptCallConv = False
 pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})
 pprTempAndExternDecls stmts
   = (pprUFM (getUniqSet temps) (vcat . map pprTempDecl),
-     vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls)))
+     vcat (map pprExternDecl (Map.keys lbls)))
   where (temps, lbls) = runTE (mapM_ te_BB stmts)
 
 pprDataExterns :: [CmmStatic] -> SDoc
 pprDataExterns statics
-  = vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls))
+  = vcat (map pprExternDecl (Map.keys lbls))
   where (_, lbls) = runTE (mapM_ te_Static statics)
 
 pprTempDecl :: LocalReg -> SDoc
 pprTempDecl l@(LocalReg _ rep)
   = hcat [ machRepCType rep, space, pprLocalReg l, semi ]
 
-pprExternDecl :: Bool -> CLabel -> SDoc
-pprExternDecl _in_srt lbl
+pprExternDecl :: CLabel -> SDoc
+pprExternDecl lbl
   -- do not print anything for "known external" things
   | not (needsCDecl lbl) = empty
   | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
   | otherwise =
-        hcat [ visibility, label_type lbl,
-               lparen, ppr lbl, text ");" ]
+        hcat [ visibility, label_type lbl , lparen, ppr lbl, text ");"
+             -- occasionally useful to see label type
+             -- , text "/* ", pprDebugCLabel lbl, text " */"
+             ]
  where
-  label_type lbl | isBytesLabel lbl     = text "B_"
-                 | isForeignLabel lbl && isCFunctionLabel lbl = text "FF_"
-                 | isCFunctionLabel lbl = text "F_"
-                 | otherwise            = text "I_"
+  label_type lbl | isBytesLabel lbl         = text "B_"
+                 | isForeignLabel lbl && isCFunctionLabel lbl
+                                            = text "FF_"
+                 | isCFunctionLabel lbl     = text "F_"
+                 | isStaticClosureLabel lbl = text "C_"
+                 -- generic .rodata labels
+                 | isSomeRODataLabel lbl    = text "RO_"
+                 -- generic .data labels (common case)
+                 | otherwise                = text "RW_"
 
   visibility
      | externallyVisibleCLabel lbl = char 'E'
diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs
index 9bb5a75bda..adb86d312d 100644
--- a/compiler/llvmGen/LlvmCodeGen/Data.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Data.hs
@@ -56,18 +56,6 @@ genLlvmData (sec, Statics lbl xs) = do
 
     return ([globDef], [tyAlias])
 
--- | Should a data in this section be considered constant
-isSecConstant :: Section -> Bool
-isSecConstant (Section t _) = case t of
-    Text                    -> True
-    ReadOnlyData            -> True
-    RelocatableReadOnlyData -> True
-    ReadOnlyData16          -> True
-    CString                 -> True
-    Data                    -> False
-    UninitialisedData       -> False
-    (OtherSection _)        -> False
-
 -- | Format the section type part of a Cmm Section
 llvmSectionType :: Platform -> SectionType -> FastString
 llvmSectionType p t = case t of
diff --git a/includes/Stg.h b/includes/Stg.h
index 619984d8e5..b1b3190307 100644
--- a/includes/Stg.h
+++ b/includes/Stg.h
@@ -223,13 +223,23 @@ typedef StgInt    I_;
 typedef StgWord StgWordArray[];
 typedef StgFunPtr       F_;
 
-#define EB_(X)    extern char X[]
-#define IB_(X)    static char X[]
-#define EI_(X)          extern StgWordArray (X) GNU_ATTRIBUTE(aligned (8))
-#define II_(X)          static StgWordArray (X) GNU_ATTRIBUTE(aligned (8))
+/* byte arrays (and strings): */
+#define EB_(X)    extern const char X[]
+#define IB_(X)    static const char X[]
+/* static (non-heap) closures (requires alignment for pointer tagging): */
+#define EC_(X)    extern       StgWordArray (X) GNU_ATTRIBUTE(aligned (8))
+#define IC_(X)    static       StgWordArray (X) GNU_ATTRIBUTE(aligned (8))
+/* writable data (does not require alignment): */
+#define ERW_(X)   extern       StgWordArray (X)
+#define IRW_(X)   static       StgWordArray (X)
+/* read-only data (does not require alignment): */
+#define ERO_(X)   extern const StgWordArray (X)
+#define IRO_(X)   static const StgWordArray (X)
+/* stg-native functions: */
 #define IF_(f)    static StgFunPtr GNUC3_ATTRIBUTE(used) f(void)
-#define FN_(f)    StgFunPtr f(void)
-#define EF_(f)    StgFunPtr f(void) /* External Cmm functions */
+#define FN_(f)           StgFunPtr f(void)
+#define EF_(f)           StgFunPtr f(void) /* External Cmm functions */
+/* foreign functions: */
 #define EFF_(f)   void f() /* See Note [External function prototypes] */
 
 /* Note [External function prototypes]  See Trac #8965, #11395
diff --git a/includes/rts/storage/InfoTables.h b/includes/rts/storage/InfoTables.h
index 307aac371c..163f1d1c87 100644
--- a/includes/rts/storage/InfoTables.h
+++ b/includes/rts/storage/InfoTables.h
@@ -266,7 +266,7 @@ typedef struct {
 } StgFunInfoTable;
 
 // canned bitmap for each arg type, indexed by constants in FunTypes.h
-extern StgWord stg_arg_bitmaps[];
+extern const StgWord stg_arg_bitmaps[];
 
 /* -----------------------------------------------------------------------------
    Return info tables
diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
index 9d907ab3ba..b604f1c42b 100644
--- a/includes/stg/MiscClosures.h
+++ b/includes/stg/MiscClosures.h
@@ -21,10 +21,10 @@
 #define STGMISCCLOSURES_H
 
 #if IN_STG_CODE
-#  define RTS_RET_INFO(i)   extern W_(i)[]
-#  define RTS_FUN_INFO(i)   extern W_(i)[]
-#  define RTS_THUNK_INFO(i) extern W_(i)[]
-#  define RTS_INFO(i)       extern W_(i)[]
+#  define RTS_RET_INFO(i)   extern const W_(i)[]
+#  define RTS_FUN_INFO(i)   extern const W_(i)[]
+#  define RTS_THUNK_INFO(i) extern const W_(i)[]
+#  define RTS_INFO(i)       extern const W_(i)[]
 #  define RTS_CLOSURE(i)    extern W_(i)[]
 #  define RTS_FUN_DECL(f)   extern DLL_IMPORT_RTS StgFunPtr f(void)
 #else
@@ -489,9 +489,9 @@ extern StgWord RTS_VAR(sched_mutex);
 
 // Apply.cmm
 // canned bitmap for each arg type
-extern StgWord stg_arg_bitmaps[];
-extern StgWord stg_ap_stack_entries[];
-extern StgWord stg_stack_save_entries[];
+extern const StgWord stg_arg_bitmaps[];
+extern const StgWord stg_ap_stack_entries[];
+extern const StgWord stg_stack_save_entries[];
 
 // Storage.c
 extern unsigned int RTS_VAR(g0);
-- 
2.12.2