<commit_before>{-# LANGUAGE CPP, GADTs #-}

-----------------------------------------------------------------------------
--
-- Pretty-printing of Cmm as C, suitable for feeding gcc
--
-- (c) The University of Glasgow 2004-2006
--
-- Print Cmm as real C, for -fvia-C
--
-- See wiki:Commentary/Compiler/Backends/PprC
--
-- This is simpler than the old PprAbsC, because Cmm is "macro-expanded"
-- relative to the old AbstractC, and many oddities/decorations have
-- disappeared from the data type.
--
-- This code generator is only supported in unregisterised mode.
--
-----------------------------------------------------------------------------

module PprC (
        writeCs,
        pprStringInCStyle
  ) where

#include "HsVersions.h"

-- Cmm stuff
import BlockId
import CLabel
import ForeignCall
import Cmm hiding (pprBBlock)
import PprCmm ()
import Hoopl
import CmmUtils
import CmmSwitch

-- Utils
import CPrim
import DynFlags
import FastString
import Outputable
import Platform
import UniqSet
import Unique
import Util

-- The rest
import Control.Monad.ST
import Data.Bits
import Data.Char
import Data.List
import Data.Map (Map)
import Data.Word
import System.IO
import qualified Data.Map as Map
import Control.Monad (liftM, ap)
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative (Applicative(..))
#endif

import qualified Data.Array.Unsafe as U ( castSTUArray )
import Data.Array.ST

-- --------------------------------------------------------------------------
-- Top level

pprCs :: DynFlags -> [RawCmmGroup] -> SDoc
pprCs dflags cmms
 = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
 where
   split_marker
     | gopt Opt_SplitObjs dflags = text "__STG_SPLIT_MARKER"
     | otherwise                 = empty

writeCs :: DynFlags -> Handle -> [RawCmmGroup] -> IO ()
writeCs dflags handle cmms
  = printForC dflags handle (pprCs dflags cmms)

-- --------------------------------------------------------------------------
-- Now do some real work
--
-- for fun, we could call cmmToCmm over the tops...
--

pprC :: RawCmmGroup -> SDoc
pprC tops = vcat $ intersperse blankLine $ map pprTop tops

--
-- top level procs
--
pprTop :: RawCmmDecl -> SDoc
pprTop (CmmProc infos clbl _ graph) =

    (case mapLookup (g_entry graph) infos of
       Nothing -> empty
       Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$
                                            pprWordArray info_clbl info_dat) $$
    (vcat [
           blankLine,
           extern_decls,
           (if (externallyVisibleCLabel clbl)
                    then mkFN_ else mkIF_) (ppr clbl) <+> lbrace,
           nest 8 temp_decls,
           vcat (map pprBBlock blocks),
           rbrace ]
    )
  where
        blocks = toBlockListEntryFirst graph
        (temp_decls, extern_decls) = pprTempAndExternDecls blocks


-- Chunks of static data.

-- We only handle (a) arrays of word-sized things and (b) strings.

pprTop (CmmData _section (Statics lbl [CmmString str])) =
  hcat [
    pprLocalness lbl, text "char ", ppr lbl,
    text "[] = ", pprStringInCStyle str, semi
  ]

pprTop (CmmData _section (Statics lbl [CmmUninitialised size])) =
  hcat [
    pprLocalness lbl, text "char ", ppr lbl,
    brackets (int size), semi
  ]

pprTop (CmmData _section (Statics lbl lits)) =
  pprDataExterns lits $$
  pprWordArray lbl lits

-- --------------------------------------------------------------------------
-- BasicBlocks are self-contained entities: they always end in a jump.
--
-- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn
-- as many jumps as possible into fall throughs.
--

pprBBlock :: CmmBlock -> SDoc
pprBBlock block =
  nest 4 (pprBlockId (entryLabel block) <> colon) $$
  nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last)
 where
  (_, nodes, last)  = blockSplit block

-- --------------------------------------------------------------------------
-- Info tables. Just arrays of words.
-- See codeGen/ClosureInfo, and nativeGen/PprMach

pprWordArray :: CLabel -> [CmmStatic] -> SDoc
pprWordArray lbl ds
  = sdocWithDynFlags $ \dflags ->
    hcat [ pprLocalness lbl, text "StgWord"
         , space, ppr lbl, text "[] = {" ]
    $$ nest 8 (commafy (pprStatics dflags ds))
    $$ text "};"

--
-- has to be static, if it isn't globally visible<commit_msg>Fix minimum alignment for StgClosure (Trac #11395)<commit_after>{-# LANGUAGE CPP, GADTs #-}

-----------------------------------------------------------------------------
--
-- Pretty-printing of Cmm as C, suitable for feeding gcc
--
-- (c) The University of Glasgow 2004-2006
--
-- Print Cmm as real C, for -fvia-C
--
-- See wiki:Commentary/Compiler/Backends/PprC
--
-- This is simpler than the old PprAbsC, because Cmm is "macro-expanded"
-- relative to the old AbstractC, and many oddities/decorations have
-- disappeared from the data type.
--
-- This code generator is only supported in unregisterised mode.
--
-----------------------------------------------------------------------------

module PprC (
        writeCs,
        pprStringInCStyle
  ) where

#include "HsVersions.h"

-- Cmm stuff
import BlockId
import CLabel
import ForeignCall
import Cmm hiding (pprBBlock)
import PprCmm ()
import Hoopl
import CmmUtils
import CmmSwitch

-- Utils
import CPrim
import DynFlags
import FastString
import Outputable
import Platform
import UniqSet
import Unique
import Util

-- The rest
import Control.Monad.ST
import Data.Bits
import Data.Char
import Data.List
import Data.Map (Map)
import Data.Word
import System.IO
import qualified Data.Map as Map
import Control.Monad (liftM, ap)
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative (Applicative(..))
#endif

import qualified Data.Array.Unsafe as U ( castSTUArray )
import Data.Array.ST

-- --------------------------------------------------------------------------
-- Top level

pprCs :: DynFlags -> [RawCmmGroup] -> SDoc
pprCs dflags cmms
 = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
 where
   split_marker
     | gopt Opt_SplitObjs dflags = text "__STG_SPLIT_MARKER"
     | otherwise                 = empty

writeCs :: DynFlags -> Handle -> [RawCmmGroup] -> IO ()
writeCs dflags handle cmms
  = printForC dflags handle (pprCs dflags cmms)

-- --------------------------------------------------------------------------
-- Now do some real work
--
-- for fun, we could call cmmToCmm over the tops...
--

pprC :: RawCmmGroup -> SDoc
pprC tops = vcat $ intersperse blankLine $ map pprTop tops

--
-- top level procs
--
pprTop :: RawCmmDecl -> SDoc
pprTop (CmmProc infos clbl _ graph) =

    (case mapLookup (g_entry graph) infos of
       Nothing -> empty
       Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$
                                            pprWordArray info_clbl info_dat) $$
    (vcat [
           blankLine,
           extern_decls,
           (if (externallyVisibleCLabel clbl)
                    then mkFN_ else mkIF_) (ppr clbl) <+> lbrace,
           nest 8 temp_decls,
           vcat (map pprBBlock blocks),
           rbrace ]
    )
  where
        blocks = toBlockListEntryFirst graph
        (temp_decls, extern_decls) = pprTempAndExternDecls blocks


-- Chunks of static data.

-- We only handle (a) arrays of word-sized things and (b) strings.

pprTop (CmmData _section (Statics lbl [CmmString str])) =
  hcat [
    pprLocalness lbl, text "char ", ppr lbl,
    text "[] = ", pprStringInCStyle str, semi
  ]

pprTop (CmmData _section (Statics lbl [CmmUninitialised size])) =
  hcat [
    pprLocalness lbl, text "char ", ppr lbl,
    brackets (int size), semi
  ]

pprTop (CmmData _section (Statics lbl lits)) =
  pprDataExterns lits $$
  pprWordArray lbl lits

-- --------------------------------------------------------------------------
-- BasicBlocks are self-contained entities: they always end in a jump.
--
-- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn
-- as many jumps as possible into fall throughs.
--

pprBBlock :: CmmBlock -> SDoc
pprBBlock block =
  nest 4 (pprBlockId (entryLabel block) <> colon) $$
  nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last)
 where
  (_, nodes, last)  = blockSplit block

-- --------------------------------------------------------------------------
-- Info tables. Just arrays of words.
-- See codeGen/ClosureInfo, and nativeGen/PprMach

pprWordArray :: CLabel -> [CmmStatic] -> SDoc
pprWordArray lbl ds
  = sdocWithDynFlags $ \dflags ->
    hcat [ pprLocalness lbl, text "StgWord"
         , space, ppr lbl, text "[]"
         -- See Note [StgWord alignment]
         , pprAlignment (wordWidth dflags)
         , text "= {" ]
    $$ nest 8 (commafy (pprStatics dflags ds))
    $$ text "};"

pprAlignment :: Width -> SDoc
pprAlignment words =
     text "__attribute__((aligned(" <> int (widthInBytes words) <> text ")))"

-- Note [StgWord alignment]
-- C codegen builds static closures as StgWord C arrays (pprWordArray).
-- Their real C type is 'StgClosure'. Macros like UNTAG_CLOSURE assume
-- pointers to 'StgClosure' are aligned at pointer size boundary:
--  4 byte boundary on 32 systems
--  and 8 bytes on 64-bit systems
-- see TAG_MASK and TAG_BITS definition and usage.
--
-- It's a reasonable assumption also known as natural alignment.
-- Although some architectures have different alignment rules.
-- One of known exceptions is m68k (Trac #11395, comment:16) where:
--   __alignof__(StgWord) == 2, sizeof(StgWord) == 4
--
-- Thus we explicitly increase alignment by using
--    __attribute__((aligned(4)))
-- declaration.

--
-- has to be static, if it isn't globally visible
{'fraction_non_alphanumeric': 0.18397749765600582, 'fraction_numerical': 0.005521408480050005, 'mean_word_length': 2.0592734225621414, 'pattern_counts': {'":': 0, '<': 11, '<?xml version=': 0, '>': 38, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 4, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6302753', 'n_tokens_mistral': 3013, 'n_tokens_neox': 2904, 'n_words': 972}