[Git][ghc/ghc][master] 5 commits: llvmGen: Add export list to GHC.Llvm.MetaData

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Fri Aug 25 14:58:49 UTC 2023



Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
fcfc1777 by Ben Gamari at 2023-08-25T10:58:16-04:00
llvmGen: Add export list to GHC.Llvm.MetaData

- - - - -
5880fff6 by Ben Gamari at 2023-08-25T10:58:16-04:00
llvmGen: Allow LlvmLits in MetaExprs

This omission appears to be an oversight.

- - - - -
86ce92a2 by Ben Gamari at 2023-08-25T10:58:16-04:00
compiler: Move platform feature predicates to GHC.Driver.DynFlags

These are useful in `GHC.Driver.Config.*`.

- - - - -
a6a38742 by Ben Gamari at 2023-08-25T10:58:16-04:00
llvmGen: Introduce infrastructure for module flag metadata

- - - - -
e9af2cf3 by Ben Gamari at 2023-08-25T10:58:16-04:00
llvmGen: Don't pass stack alignment via command line

As of https://reviews.llvm.org/D103048 LLVM no longer supports the
`-stack-alignment=...` flag. Instead this information is passed via a
module flag metadata node.

This requires dropping support for LLVM 11 and 12.

Fixes #23870

- - - - -


10 changed files:

- compiler/GHC/CmmToLlvm.hs
- compiler/GHC/CmmToLlvm/Config.hs
- compiler/GHC/Driver/Config/CmmToLlvm.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Llvm.hs
- compiler/GHC/Llvm/MetaData.hs
- compiler/GHC/Llvm/Ppr.hs
- configure.ac


Changes:

=====================================
compiler/GHC/CmmToLlvm.hs
=====================================
@@ -196,7 +196,7 @@ cmmLlvmGen _ = return ()
 
 cmmMetaLlvmPrelude :: LlvmM ()
 cmmMetaLlvmPrelude = do
-  metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do
+  tbaa_metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do
     -- Generate / lookup meta data IDs
     tbaaId <- getMetaUniqueId
     setUniqMeta uniq tbaaId
@@ -209,10 +209,37 @@ cmmMetaLlvmPrelude = do
               -- just a name on its own. Previously `null` was accepted as the
               -- name.
               Nothing -> [ MetaStr name ]
+
+  platform <- getPlatform
+  cfg <- getConfig
+  let stack_alignment_metas =
+          case platformArch platform of
+            ArchX86_64 | llvmCgAvxEnabled cfg -> [mkStackAlignmentMeta 32]
+            _                                 -> []
+  module_flags_metas <- mkModuleFlagsMeta stack_alignment_metas
+  let metas = tbaa_metas ++ module_flags_metas
   cfg <- getConfig
   renderLlvm (ppLlvmMetas cfg metas)
              (ppLlvmMetas cfg metas)
 
+mkNamedMeta :: LMString -> [MetaExpr] -> LlvmM [MetaDecl]
+mkNamedMeta name exprs = do
+    (ids, decls) <- unzip <$> mapM f exprs
+    return $ decls ++ [MetaNamed name ids]
+  where
+    f expr = do
+      i <- getMetaUniqueId
+      return (i, MetaUnnamed i expr)
+
+mkModuleFlagsMeta :: [ModuleFlag] -> LlvmM [MetaDecl]
+mkModuleFlagsMeta =
+    mkNamedMeta "llvm.module.flags" . map moduleFlagToMetaExpr
+
+mkStackAlignmentMeta :: Integer -> ModuleFlag
+mkStackAlignmentMeta alignment =
+    ModuleFlag MFBError "override-stack-alignment" (MetaLit $ LMIntLit alignment i32)
+
+
 -- -----------------------------------------------------------------------------
 -- | Marks variables as used where necessary
 --


=====================================
compiler/GHC/CmmToLlvm/Config.hs
=====================================
@@ -36,6 +36,7 @@ data LlvmCgConfig = LlvmCgConfig
   , llvmCgContext           :: !SDocContext  -- ^ Context for LLVM code generation
   , llvmCgFillUndefWithGarbage :: !Bool      -- ^ Fill undefined literals with garbage values
   , llvmCgSplitSection      :: !Bool         -- ^ Split sections
+  , llvmCgAvxEnabled        :: !Bool
   , llvmCgBmiVersion        :: Maybe BmiVersion  -- ^ (x86) BMI instructions
   , llvmCgLlvmVersion       :: Maybe LlvmVersion -- ^ version of Llvm we're using
   , llvmCgDoWarn            :: !Bool         -- ^ True ==> warn unsupported Llvm version


=====================================
compiler/GHC/Driver/Config/CmmToLlvm.hs
=====================================
@@ -23,6 +23,7 @@ initLlvmCgConfig logger config_cache dflags = do
     , llvmCgContext              = initSDocContext dflags PprCode
     , llvmCgFillUndefWithGarbage = gopt Opt_LlvmFillUndefWithGarbage dflags
     , llvmCgSplitSection         = gopt Opt_SplitSections dflags
+    , llvmCgAvxEnabled           = isAvxEnabled dflags
     , llvmCgBmiVersion           = case platformArch (targetPlatform dflags) of
                                       ArchX86_64 -> bmiVersion dflags
                                       ArchX86    -> bmiVersion dflags


=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -71,6 +71,18 @@ module GHC.Driver.DynFlags (
         -- * SDoc
         initSDocContext, initDefaultSDocContext,
         initPromotionTickContext,
+
+        -- * Platform features
+        isSse4_2Enabled,
+        isAvxEnabled,
+        isAvx2Enabled,
+        isAvx512cdEnabled,
+        isAvx512erEnabled,
+        isAvx512fEnabled,
+        isAvx512pfEnabled,
+        isFmaEnabled,
+        isBmiEnabled,
+        isBmi2Enabled
 ) where
 
 import GHC.Prelude
@@ -1521,3 +1533,45 @@ initPromotionTickContext dflags =
     ptcListTuplePuns = True,
     ptcPrintRedundantPromTicks = gopt Opt_PrintRedundantPromotionTicks dflags
   }
+
+-- -----------------------------------------------------------------------------
+-- SSE, AVX, FMA
+
+isSse4_2Enabled :: DynFlags -> Bool
+isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42
+
+isAvxEnabled :: DynFlags -> Bool
+isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags
+
+isAvx2Enabled :: DynFlags -> Bool
+isAvx2Enabled dflags = avx2 dflags || avx512f dflags
+
+isAvx512cdEnabled :: DynFlags -> Bool
+isAvx512cdEnabled dflags = avx512cd dflags
+
+isAvx512erEnabled :: DynFlags -> Bool
+isAvx512erEnabled dflags = avx512er dflags
+
+isAvx512fEnabled :: DynFlags -> Bool
+isAvx512fEnabled dflags = avx512f dflags
+
+isAvx512pfEnabled :: DynFlags -> Bool
+isAvx512pfEnabled dflags = avx512pf dflags
+
+isFmaEnabled :: DynFlags -> Bool
+isFmaEnabled dflags = fma dflags
+
+-- -----------------------------------------------------------------------------
+-- BMI2
+
+isBmiEnabled :: DynFlags -> Bool
+isBmiEnabled dflags = case platformArch (targetPlatform dflags) of
+    ArchX86_64 -> bmiVersion dflags >= Just BMI1
+    ArchX86    -> bmiVersion dflags >= Just BMI1
+    _          -> False
+
+isBmi2Enabled :: DynFlags -> Bool
+isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of
+    ArchX86_64 -> bmiVersion dflags >= Just BMI2
+    ArchX86    -> bmiVersion dflags >= Just BMI2
+    _          -> False


=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -948,8 +948,6 @@ llvmOptions llvm_config dflags =
        [("-enable-tbaa -tbaa",  "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]
     ++ [("-relocation-model=" ++ rmodel
         ,"-relocation-model=" ++ rmodel) | not (null rmodel)]
-    ++ [("-stack-alignment=" ++ (show align)
-        ,"-stack-alignment=" ++ (show align)) | align > 0 ]
 
     -- Additional llc flags
     ++ [("", "-mcpu=" ++ mcpu)   | not (null mcpu)
@@ -968,11 +966,6 @@ llvmOptions llvm_config dflags =
 
         platform = targetPlatform dflags
 
-        align :: Int
-        align = case platformArch platform of
-                  ArchX86_64 | isAvxEnabled dflags -> 32
-                  _                                -> 0
-
         attrs :: String
         attrs = intercalate "," $ mattr
               ++ ["+sse42"   | isSse4_2Enabled dflags   ]


=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -3727,48 +3727,6 @@ setUnsafeGlobalDynFlags dflags = do
    writeIORef v_unsafeHasNoStateHack (hasNoStateHack dflags)
 
 
--- -----------------------------------------------------------------------------
--- SSE, AVX, FMA
-
-isSse4_2Enabled :: DynFlags -> Bool
-isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42
-
-isAvxEnabled :: DynFlags -> Bool
-isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags
-
-isAvx2Enabled :: DynFlags -> Bool
-isAvx2Enabled dflags = avx2 dflags || avx512f dflags
-
-isAvx512cdEnabled :: DynFlags -> Bool
-isAvx512cdEnabled dflags = avx512cd dflags
-
-isAvx512erEnabled :: DynFlags -> Bool
-isAvx512erEnabled dflags = avx512er dflags
-
-isAvx512fEnabled :: DynFlags -> Bool
-isAvx512fEnabled dflags = avx512f dflags
-
-isAvx512pfEnabled :: DynFlags -> Bool
-isAvx512pfEnabled dflags = avx512pf dflags
-
-isFmaEnabled :: DynFlags -> Bool
-isFmaEnabled dflags = fma dflags
-
--- -----------------------------------------------------------------------------
--- BMI2
-
-isBmiEnabled :: DynFlags -> Bool
-isBmiEnabled dflags = case platformArch (targetPlatform dflags) of
-    ArchX86_64 -> bmiVersion dflags >= Just BMI1
-    ArchX86    -> bmiVersion dflags >= Just BMI1
-    _          -> False
-
-isBmi2Enabled :: DynFlags -> Bool
-isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of
-    ArchX86_64 -> bmiVersion dflags >= Just BMI2
-    ArchX86    -> bmiVersion dflags >= Just BMI2
-    _          -> False
-
 -- -----------------------------------------------------------------------------
 
 -- | Indicate if cost-centre profiling is enabled


=====================================
compiler/GHC/Llvm.hs
=====================================
@@ -42,6 +42,10 @@ module GHC.Llvm (
 
         -- ** Metadata types
         MetaExpr(..), MetaAnnot(..), MetaDecl(..), MetaId(..),
+        -- *** Module flags
+        ModuleFlagBehavior(..),
+        ModuleFlag(..),
+        moduleFlagToMetaExpr,
 
         -- ** Operations on the type system.
         isGlobal, getLitType, getVarType,


=====================================
compiler/GHC/Llvm/MetaData.hs
=====================================
@@ -1,6 +1,16 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
-module GHC.Llvm.MetaData where
+module GHC.Llvm.MetaData
+  ( MetaId(..)
+  , ppMetaId
+  , MetaExpr(..)
+  , MetaAnnot(..)
+  , MetaDecl(..)
+    -- * Module flags
+  , ModuleFlagBehavior(..)
+  , ModuleFlag(..)
+  , moduleFlagToMetaExpr
+  ) where
 
 import GHC.Prelude
 
@@ -73,6 +83,7 @@ ppMetaId (MetaId n) = char '!' <> int n
 
 -- | LLVM metadata expressions
 data MetaExpr = MetaStr !LMString
+              | MetaLit !LlvmLit
               | MetaNode !MetaId
               | MetaVar !LlvmVar
               | MetaStruct [MetaExpr]
@@ -91,3 +102,42 @@ data MetaDecl
     -- | Metadata node declaration.
     -- ('!0 = metadata !{ \<metadata expression> }' form).
     | MetaUnnamed !MetaId !MetaExpr
+
+----------------------------------------------------------------
+-- Module flags
+----------------------------------------------------------------
+data ModuleFlagBehavior
+  = MFBError
+  | MFBWarning
+  | MFBRequire
+  | MFBOverride
+  | MFBAppend
+  | MFBAppendUnique
+  | MFBMax
+  | MFBMin
+
+moduleFlagBehaviorToMetaExpr :: ModuleFlagBehavior -> MetaExpr
+moduleFlagBehaviorToMetaExpr mfb =
+    MetaLit $ LMIntLit n i32
+  where
+    n = case mfb of
+      MFBError -> 1
+      MFBWarning -> 2
+      MFBRequire -> 3
+      MFBOverride -> 4
+      MFBAppend -> 5
+      MFBAppendUnique -> 6
+      MFBMax -> 7
+      MFBMin -> 8
+
+data ModuleFlag = ModuleFlag { mfBehavior :: ModuleFlagBehavior
+                             , mfName :: LMString
+                             , mfValue :: MetaExpr
+                             }
+
+moduleFlagToMetaExpr :: ModuleFlag -> MetaExpr
+moduleFlagToMetaExpr flag = MetaStruct
+    [ moduleFlagBehaviorToMetaExpr (mfBehavior flag)
+    , MetaStr (mfName flag)
+    , mfValue flag
+    ]


=====================================
compiler/GHC/Llvm/Ppr.hs
=====================================
@@ -299,6 +299,7 @@ ppMetaExpr :: IsLine doc => LlvmCgConfig -> MetaExpr -> doc
 ppMetaExpr opts = \case
   MetaVar (LMLitVar (LMNullLit _)) -> text "null"
   MetaStr    s                     -> char '!' <> doubleQuotes (ftext s)
+  MetaLit    l                     -> ppTypeLit opts l
   MetaNode   n                     -> ppMetaId n
   MetaVar    v                     -> ppVar opts v
   MetaStruct es                    -> char '!' <> braces (ppCommaJoin (ppMetaExpr opts) es)


=====================================
configure.ac
=====================================
@@ -539,7 +539,7 @@ AC_SUBST(InstallNameToolCmd)
 # tools we are looking for. In the past, GHC supported a number of
 # versions of LLVM simultaneously, but that stopped working around
 # 3.5/3.6 release of LLVM.
-LlvmMinVersion=11  # inclusive
+LlvmMinVersion=13  # inclusive
 LlvmMaxVersion=16 # not inclusive
 AC_SUBST([LlvmMinVersion])
 AC_SUBST([LlvmMaxVersion])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d3e0124c1157a4a423d86a1dc1d7e82c6d32ef06...e9af2cf3f16ab60b5c79ed91df95359b11784df6

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d3e0124c1157a4a423d86a1dc1d7e82c6d32ef06...e9af2cf3f16ab60b5c79ed91df95359b11784df6
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/20230825/869d0331/attachment-0001.html>


More information about the ghc-commits mailing list