llvmGen: move to LLVM 3.6 exclusively

Summary:
Rework llvmGen to use LLVM 3.6 exclusively. The plans for the 7.12 release are to ship LLVM alongside GHC in the interests of user (and developer) sanity.

Along the way, refactor TNTC support to take advantage of the new `prefix` data support in LLVM 3.6. This allows us to drop the section-reordering component of the LLVM mangler.

Test Plan: Validate, look at emitted code

Reviewers: dterei, austin, scpmw

Reviewed By: austin

Subscribers: erikd, awson, spacekitteh, thomie, carter

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

GHC Trac Issues: #10074

8 files changed, 72 insertions, 166 deletions

diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs
index 24d0856ea3..b0eae2cbfe 100644
--- a/compiler/llvmGen/Llvm/AbsSyn.hs
+++ b/compiler/llvmGen/Llvm/AbsSyn.hs
@@ -48,19 +48,22 @@ data LlvmModule = LlvmModule  {
 -- | An LLVM Function
 data LlvmFunction = LlvmFunction {
     -- | The signature of this declared function.
-    funcDecl  :: LlvmFunctionDecl,
+    funcDecl      :: LlvmFunctionDecl,
 
     -- | The functions arguments
-    funcArgs  :: [LMString],
+    funcArgs      :: [LMString],
 
     -- | The function attributes.
-    funcAttrs :: [LlvmFuncAttr],
+    funcAttrs     :: [LlvmFuncAttr],
 
     -- | The section to put the function into,
-    funcSect  :: LMSection,
+    funcSect      :: LMSection,
+
+    -- | Prefix data
+    funcPrefix    :: Maybe LlvmStatic,
 
     -- | The body of the functions.
-    funcBody  :: LlvmBlocks
+    funcBody      :: LlvmBlocks
   }
 
 type LlvmFunctions = [LlvmFunction]
diff --git a/compiler/llvmGen/Llvm/MetaData.hs b/compiler/llvmGen/Llvm/MetaData.hs
index 36efcd7159..e1e63c9191 100644
--- a/compiler/llvmGen/Llvm/MetaData.hs
+++ b/compiler/llvmGen/Llvm/MetaData.hs
@@ -20,12 +20,12 @@ import Outputable
 --   information. They consist of metadata strings, metadata nodes, regular
 --   LLVM values (both literals and references to global variables) and
 --   metadata expressions (i.e., recursive data type). Some examples:
---     !{ metadata !"hello", metadata !0, i32 0 }
---     !{ metadata !1, metadata !{ i32 0 } }
+--     !{ !"hello", !0, i32 0 }
+--     !{ !1, !{ i32 0 } }
 --
 -- * Metadata nodes -- global metadata variables that attach a metadata
 --   expression to a number. For example:
---     !0 = metadata !{ [<metadata expressions>] !}
+--     !0 = !{ [<metadata expressions>] !}
 --
 -- * Named metadata -- global metadata variables that attach a metadata nodes
 --   to a name. Used ONLY to communicated module level information to LLVM
@@ -39,7 +39,7 @@ import Outputable
 -- * Attach to instructions -- metadata can be attached to LLVM instructions
 --   using a specific reference as follows:
 --     %l = load i32* @glob, !nontemporal !10
---     %m = load i32* @glob, !nontemporal !{ i32 0, metadata !{ i32 0 } }
+--     %m = load i32* @glob, !nontemporal !{ i32 0, !{ i32 0 } }
 --   Only metadata nodes or expressions can be attached, named metadata cannot.
 --   Refer to LLVM documentation for which instructions take metadata and its
 --   meaning.
@@ -63,10 +63,10 @@ data MetaExpr = MetaStr LMString
               deriving (Eq)
 
 instance Outputable MetaExpr where
-  ppr (MetaStr    s ) = text "metadata !\"" <> ftext s <> char '"'
-  ppr (MetaNode   n ) = text "metadata !" <> int n
+  ppr (MetaStr    s ) = text "!\"" <> ftext s <> char '"'
+  ppr (MetaNode   n ) = text "!" <> int n
   ppr (MetaVar    v ) = ppr v
-  ppr (MetaStruct es) = text "metadata !{ " <> ppCommaJoin es <> char '}'
+  ppr (MetaStruct es) = text "!{ " <> ppCommaJoin es <> char '}'
 
 -- | Associates some metadata with a specific label for attaching to an
 -- instruction.
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index 73077257f8..0b3deac764 100644
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -77,12 +77,12 @@ ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
             Nothing   -> ppr (pLower $ getVarType var)
 
         -- Position of linkage is different for aliases.
-        const_link = case c of
-          Global   -> ppr link <+> text "global"
-          Constant -> ppr link <+> text "constant"
-          Alias    -> text "alias" <+> ppr link
+        const = case c of
+          Global   -> text "global"
+          Constant -> text "constant"
+          Alias    -> text "alias"
 
-    in ppAssignment var $ const_link <+> rhs <> sect <> align
+    in ppAssignment var $ ppr link <+> const <+> rhs <> sect <> align
        $+$ newLine
 
 ppLlvmGlobal (LMGlobal var val) = sdocWithDynFlags $ \dflags ->
@@ -117,11 +117,11 @@ ppLlvmMeta (MetaNamed n m)
 
 -- | Print out an LLVM metadata value.
 ppLlvmMetaExpr :: MetaExpr -> SDoc
-ppLlvmMetaExpr (MetaStr    s ) = text "metadata !" <> doubleQuotes (ftext s)
-ppLlvmMetaExpr (MetaNode   n ) = text "metadata !" <> int n
+ppLlvmMetaExpr (MetaStr    s ) = text "!" <> doubleQuotes (ftext s)
+ppLlvmMetaExpr (MetaNode   n ) = text "!" <> int n
 ppLlvmMetaExpr (MetaVar    v ) = ppr v
 ppLlvmMetaExpr (MetaStruct es) =
-    text "metadata !{" <> hsep (punctuate comma (map ppLlvmMetaExpr es)) <> char '}'
+    text "!{" <> hsep (punctuate comma (map ppLlvmMetaExpr es)) <> char '}'
 
 
 -- | Print out a list of function definitions.
@@ -130,15 +130,18 @@ ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs
 
 -- | Print out a function definition.
 ppLlvmFunction :: LlvmFunction -> SDoc
-ppLlvmFunction (LlvmFunction dec args attrs sec body) =
-    let attrDoc = ppSpaceJoin attrs
-        secDoc = case sec of
+ppLlvmFunction fun =
+    let attrDoc = ppSpaceJoin (funcAttrs fun)
+        secDoc = case funcSect fun of
                       Just s' -> text "section" <+> (doubleQuotes $ ftext s')
                       Nothing -> empty
-    in text "define" <+> ppLlvmFunctionHeader dec args
-        <+> attrDoc <+> secDoc
+        prefixDoc = case funcPrefix fun of
+                        Just v  -> text "prefix" <+> ppr v
+                        Nothing -> empty
+    in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun)
+        <+> attrDoc <+> secDoc <+> prefixDoc
         $+$ lbrace
-        $+$ ppLlvmBlocks body
+        $+$ ppLlvmBlocks (funcBody fun)
         $+$ rbrace
         $+$ newLine
         $+$ newLine
@@ -269,7 +272,7 @@ ppCall ct fptr args attrs = case fptr of
     where
         ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
             let tc = if ct == TailCall then text "tail " else empty
-                ppValues = ppCommaJoin args
+                ppValues = hsep $ punctuate comma $ map ppCallMetaExpr args
                 ppArgTy  = (ppCommaJoin $ map fst params) <>
                            (case argTy of
                                VarArgs   -> text ", ..."
@@ -280,6 +283,10 @@ ppCall ct fptr args attrs = case fptr of
                     <> fnty <+> ppName fptr <> lparen <+> ppValues
                     <+> rparen <+> attrDoc
 
+        -- Metadata needs to be marked as having the `metadata` type when used
+        -- in a call argument
+        ppCallMetaExpr (MetaVar v) = ppr v
+        ppCallMetaExpr v           = text "metadata" <+> ppr v
 
 ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
 ppMachOp op left right =
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index 6120a72d3a..f0c184a348 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -138,13 +138,8 @@ cmmLlvmGen cmm@CmmProc{} = do
     -- generate llvm code from cmm
     llvmBC <- withClearVars $ genLlvmProc fixed_cmm
 
-    -- allocate IDs for info table and code, so the mangler can later
-    -- make sure they end up next to each other.
-    itableSection <- freshSectionId
-    _codeSection <- freshSectionId
-
     -- pretty print
-    (docs, ivars) <- fmap unzip $ mapM (pprLlvmCmmDecl itableSection) llvmBC
+    (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC
 
     -- Output, note down used variables
     renderLlvm (vcat docs)
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 83b06a9a1b..15918a3a45 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -24,11 +24,10 @@ module LlvmCodeGen.Base (
 
         getMetaUniqueId,
         setUniqMeta, getUniqMeta,
-        freshSectionId,
 
         cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
-        llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
-        llvmPtrBits, mkLlvmFunc, tysToParams,
+        llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
+        llvmPtrBits, tysToParams,
 
         strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
         getGlobalPtr, generateExternDecls,
@@ -133,15 +132,6 @@ llvmFunSig' live lbl link
                                  (map (toParams . getVarType) (llvmFunArgs dflags live))
                                  (llvmFunAlign dflags)
 
--- | Create a Haskell function in LLVM.
-mkLlvmFunc :: LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
-           -> LlvmM LlvmFunction
-mkLlvmFunc live lbl link sec blks
-  = do funDec <- llvmFunSig live lbl link
-       dflags <- getDynFlags
-       let funArgs = map (fsLit . Outp.showSDoc dflags . ppPlainName) (llvmFunArgs dflags live)
-       return $ LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
-
 -- | Alignment to use for functions
 llvmFunAlign :: DynFlags -> LMAlign
 llvmFunAlign dflags = Just (wORD_SIZE dflags)
@@ -186,13 +176,13 @@ type LlvmVersion = Int
 
 -- | The LLVM Version we assume if we don't know
 defaultLlvmVersion :: LlvmVersion
-defaultLlvmVersion = 30
+defaultLlvmVersion = 36
 
 minSupportLlvmVersion :: LlvmVersion
-minSupportLlvmVersion = 28
+minSupportLlvmVersion = 36
 
 maxSupportLlvmVersion :: LlvmVersion
-maxSupportLlvmVersion = 35
+maxSupportLlvmVersion = 36
 
 -- ----------------------------------------------------------------------------
 -- * Environment Handling
@@ -203,7 +193,6 @@ data LlvmEnv = LlvmEnv
   , envDynFlags :: DynFlags        -- ^ Dynamic flags
   , envOutput :: BufHandle         -- ^ Output buffer
   , envUniq :: UniqSupply          -- ^ Supply of unique values
-  , envNextSection :: Int          -- ^ Supply of fresh section IDs
   , envFreshMeta :: Int            -- ^ Supply of fresh metadata IDs
   , envUniqMeta :: UniqFM Int      -- ^ Global metadata nodes
   , envFunMap :: LlvmEnvMap        -- ^ Global functions so far, with type
@@ -257,7 +246,6 @@ runLlvm dflags ver out us m = do
                       , envUniq = us
                       , envFreshMeta = 0
                       , envUniqMeta = emptyUFM
-                      , envNextSection = 1
                       }
 
 -- | Get environment (internal)
@@ -362,10 +350,6 @@ setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta
 getUniqMeta :: Unique -> LlvmM (Maybe Int)
 getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta)
 
--- | Returns a fresh section ID
-freshSectionId :: LlvmM Int
-freshSectionId = LlvmM $ \env -> return (envNextSection env, env { envNextSection = envNextSection env + 1})
-
 -- ----------------------------------------------------------------------------
 -- * Internal functions
 --
diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs
index 90ce44367a..42f4dcd599 100644
--- a/compiler/llvmGen/LlvmCodeGen/Data.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Data.hs
@@ -4,7 +4,7 @@
 --
 
 module LlvmCodeGen.Data (
-        genLlvmData
+        genLlvmData, genData
     ) where
 
 #include "HsVersions.h"
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index 5dd27ab33b..1a9373bce2 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -4,7 +4,7 @@
 -- | Pretty print helpers for the LLVM Code generator.
 --
 module LlvmCodeGen.Ppr (
-        pprLlvmHeader, pprLlvmCmmDecl, pprLlvmData, infoSection, iTableSuf
+        pprLlvmHeader, pprLlvmCmmDecl, pprLlvmData, infoSection
     ) where
 
 #include "HsVersions.h"
@@ -96,28 +96,36 @@ pprLlvmData (globals, types) =
 
 
 -- | Pretty print LLVM code
-pprLlvmCmmDecl :: Int -> LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
-pprLlvmCmmDecl _ (CmmData _ lmdata)
+pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
+pprLlvmCmmDecl (CmmData _ lmdata)
   = return (vcat $ map pprLlvmData lmdata, [])
 
-pprLlvmCmmDecl count (CmmProc mb_info entry_lbl live (ListGraph blks))
-  = do (idoc, ivar) <- case mb_info of
-                        Nothing -> return (empty, [])
-                        Just (Statics info_lbl dat)
-                         -> pprInfoTable count info_lbl (Statics entry_lbl dat)
-
-       let sec = mkLayoutSection (count + 1)
-           (lbl',sec') = case mb_info of
-                           Nothing                   -> (entry_lbl, Nothing)
-                           Just (Statics info_lbl _) -> (info_lbl,  sec)
-           link = if externallyVisibleCLabel lbl'
+pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
+  = do let lbl = case mb_info of
+                     Nothing                   -> entry_lbl
+                     Just (Statics info_lbl _) -> info_lbl
+           link = if externallyVisibleCLabel lbl
                       then ExternallyVisible
                       else Internal
            lmblocks = map (\(BasicBlock id stmts) ->
                                 LlvmBlock (getUnique id) stmts) blks
 
-       fun <- mkLlvmFunc live lbl' link  sec' lmblocks
-       let name = decName $ funcDecl fun
+       funDec <- llvmFunSig live lbl link
+       dflags <- getDynFlags
+       let buildArg = fsLit . showSDoc dflags . ppPlainName
+           funArgs = map buildArg (llvmFunArgs dflags live)
+
+       -- generate the info table
+       prefix <- case mb_info of
+                     Nothing -> return Nothing
+                     Just (Statics _ statics) -> do
+                       infoStatics <- mapM genData statics
+                       let infoTy = LMStruct $ map getStatType infoStatics
+                       return $ Just $ LMStaticStruc infoStatics infoTy
+
+       let fun = LlvmFunction funDec funArgs llvmStdFunAttrs Nothing
+                              prefix lmblocks
+           name = decName $ funcDecl fun
            defName = name `appendFS` fsLit "$def"
            funcDecl' = (funcDecl fun) { decName = defName }
            fun' = fun { funcDecl = funcDecl' }
@@ -138,55 +146,7 @@ pprLlvmCmmDecl count (CmmProc mb_info entry_lbl live (ListGraph blks))
                             (Just $ LMBitc (LMStaticPointer defVar)
                                            (LMPointer $ LMInt 8))
 
-       return (ppLlvmGlobal alias $+$ idoc $+$ ppLlvmFunction fun', ivar)
-
-
--- | Pretty print CmmStatic
-pprInfoTable :: Int -> CLabel -> CmmStatics -> LlvmM (SDoc, [LlvmVar])
-pprInfoTable count info_lbl stat
-  = do (ldata, ltypes) <- genLlvmData (Text, stat)
-
-       dflags <- getDynFlags
-       platform <- getLlvmPlatform
-       let setSection :: LMGlobal -> LlvmM (LMGlobal, [LlvmVar])
-           setSection (LMGlobal (LMGlobalVar _ ty l _ _ c) d) = do
-             lbl <- strCLabel_llvm info_lbl
-             let sec = mkLayoutSection count
-                 ilabel = lbl `appendFS` fsLit iTableSuf
-                 gv = LMGlobalVar ilabel ty l sec (llvmInfAlign dflags) c
-                 -- See Note [Subsections Via Symbols]
-                 v = if (platformHasSubsectionsViaSymbols platform
-                         && l == ExternallyVisible)
-                        || l == Internal
-                     then [gv]
-                     else []
-             funInsert ilabel ty
-             return (LMGlobal gv d, v)
-           setSection v = return (v,[])
-
-       (ldata', llvmUsed) <- unzip `fmap` mapM setSection ldata
-       ldata'' <- mapM aliasify ldata'
-       let modUsedLabel (LMGlobalVar name ty link sect align const) =
-             LMGlobalVar (name `appendFS` fsLit "$def") ty link sect align const
-           modUsedLabel v = v
-           llvmUsed' = map modUsedLabel $ concat llvmUsed
-       return (pprLlvmData (concat ldata'', ltypes), llvmUsed')
-
-
--- | We generate labels for info tables by converting them to the same label
--- as for the entry code but adding this string as a suffix.
-iTableSuf :: String
-iTableSuf = "_itable"
-
-
--- | Create a specially crafted section declaration that encodes the order this
--- section should be in the final object code.
---
--- The LlvmMangler.llvmFixupAsm pass over the assembly produced by LLVM uses
--- this section declaration to do its processing.
-mkLayoutSection :: Int -> LMSection
-mkLayoutSection n
-  = Just (fsLit $ infoSection ++ show n)
+       return (ppLlvmGlobal alias $+$ ppLlvmFunction fun', [])
 
 
 -- | The section we are putting info tables and their entry code into, should
diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs
index 8652a890cf..267feb5159 100644
--- a/compiler/llvmGen/LlvmMangler.hs
+++ b/compiler/llvmGen/LlvmMangler.hs
@@ -11,33 +11,24 @@ module LlvmMangler ( llvmFixupAsm ) where
 
 import DynFlags ( DynFlags )
 import ErrUtils ( showPass )
-import LlvmCodeGen.Ppr ( infoSection )
 
 import Control.Exception
 import Control.Monad ( when )
 import qualified Data.ByteString.Char8 as B
-import Data.Char
 import System.IO
 
-import Data.List ( sortBy )
-import Data.Function ( on )
-
 #if x86_64_TARGET_ARCH
 #define REWRITE_AVX
 #endif
 
 -- Magic Strings
-secStmt, infoSec, newLine, textStmt, dataStmt, syntaxUnified :: B.ByteString
+secStmt, newLine, textStmt, dataStmt, syntaxUnified :: B.ByteString
 secStmt       = B.pack "\t.section\t"
-infoSec       = B.pack infoSection
 newLine       = B.pack "\n"
 textStmt      = B.pack "\t.text"
 dataStmt      = B.pack "\t.data"
 syntaxUnified = B.pack "\t.syntax unified"
 
-infoLen :: Int
-infoLen = B.length infoSec
-
 -- Search Predicates
 isType :: B.ByteString -> Bool
 isType = B.isPrefixOf (B.pack "\t.type")
@@ -53,7 +44,7 @@ llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} do
     w <- openBinaryFile f2 WriteMode
     ss <- readSections r w
     hClose r
-    let fixed = (map rewriteAVX . fixTables) ss
+    let fixed = map rewriteAVX ss
     mapM_ (writeSection w) fixed
     hClose w
     return ()
@@ -91,11 +82,7 @@ readSections r w = go B.empty [] []
 
       -- Decide whether to directly output the section or append it
       -- to the list for resorting.
-      let finishSection
-            | infoSec `B.isInfixOf` hdr =
-                cts `seq` return $ (hdr, cts):ss
-            | otherwise =
-                writeSection w (hdr, cts) >> return ss
+      let finishSection = writeSection w (hdr, cts) >> return ss
 
       case e_l of
         Right l | l == syntaxUnified
@@ -149,33 +136,3 @@ replace matchBS replaceBS = loop
           (hd,tl) | B.null tl -> hd
                   | otherwise -> hd `B.append` replaceBS `B.append`
                                  loop (B.drop (B.length matchBS) tl)
-
--- | Reorder and convert sections so info tables end up next to the
--- code. Also does stack fixups.
-fixTables :: [Section] -> [Section]
-fixTables ss = map strip sorted
-  where
-    -- Resort sections: We only assign a non-zero number to all
-    -- sections having the "STRIP ME" marker. As sortBy is stable,
-    -- this will cause all these sections to be appended to the end of
-    -- the file in the order given by the indexes.
-    extractIx hdr
-      | B.null a  = 0
-      | otherwise = 1 + readInt (B.takeWhile isDigit $ B.drop infoLen a)
-      where (_,a) = B.breakSubstring infoSec hdr
-
-    indexed = zip (map (extractIx . fst) ss) ss
-
-    sorted = map snd $ sortBy (compare `on` fst) indexed
-
-    -- Turn all the "STRIP ME" sections into normal text sections, as
-    -- they are in the right place now.
-    strip (hdr, cts)
-      | infoSec `B.isInfixOf` hdr = (textStmt, cts)
-      | otherwise                 = (hdr, cts)
-
--- | Read an int or error
-readInt :: B.ByteString -> Int
-readInt str | B.all isDigit str = (read . B.unpack) str
-            | otherwise = error $ "LLvmMangler Cannot read " ++ show str
-                                ++ " as it's not an Int"