LLVM: Support LLVM 2.9 (#5103)

Instead of using the GNU As subsection feature on Linux/Windows
for TNTC we now use the LLVM Mangler on all platforms.

compiler/llvmGen/LlvmCodeGen/Ppr.hs

@@ -122,34 +122,25 @@ pprInfoTable env count lbl stat
           then Outputable.panic "LlvmCodeGen.Ppr: invalid info table!"
           else (pprLlvmData ([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 an appropriate section declaration for subsection <n> of text
--- WARNING: This technique could fail as gas documentation says it only
--- supports up to 8192 subsections per section. Inspection of the source
--- code and some test programs seem to suggest it supports more than this
--- so we are hoping it does.
+-- | 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
-  -- On OSX we can't use the GNU Assembler, we must use the OSX assembler, which
-  -- doesn't support subsections. So we post process the assembly code, this
-  -- section specifier will be replaced with '.text' by the mangler.
-  = Just (fsLit $ infoSection ++ show n
-#if darwin_TARGET_OS
-      )
-#else
-      ++ "#")
-#endif
+  = Just (fsLit $ infoSection ++ show n)
 
--- | The section we are putting info tables and their entry code into
+
+-- | The section we are putting info tables and their entry code into, should
+-- be unique since we process the assembly pattern matching this.
 infoSection :: String
-#if darwin_TARGET_OS
-infoSection = "__STRIP,__me"
-#else
-infoSection = ".text; .text "
-#endif
+infoSection = "X98A__STRIP,__me"
 

compiler/llvmGen/LlvmMangler.hs

+{-# OPTIONS -fno-warn-unused-binds #-}
 -- -----------------------------------------------------------------------------
 -- | GHC LLVM Mangler
 --
 -- This script processes the assembly produced by LLVM, rearranging the code
--- so that an info table appears before its corresponding function. We also
--- use it to fix up the stack alignment, which needs to be 16 byte aligned
--- but always ends up off by 4 bytes because GHC sets it to the 'wrong'
--- starting value in the RTS.
+-- so that an info table appears before its corresponding function.
 --
--- We only need this for Mac OS X, other targets don't use it.
+-- On OSX we also use it to fix up the stack alignment, which needs to be 16
+-- byte aligned but always ends up off by word bytes because GHC sets it to
+-- the 'wrong' starting value in the RTS.
 --
 
 module LlvmMangler ( llvmFixupAsm ) where
 
 #include "HsVersions.h"
 
+import LlvmCodeGen.Ppr ( infoSection )
+
 import Control.Exception
 import qualified Data.ByteString.Char8 as B
 import Data.Char
@@ -21,8 +23,9 @@ import qualified Data.IntMap as I
 import System.IO
 
 -- Magic Strings
-infoSec, newInfoSec, newLine, spInst, jmpInst :: B.ByteString
-infoSec    = B.pack "\t.section\t__STRIP,__me"
+secStmt, infoSec, newInfoSec, newLine, spInst, jmpInst :: B.ByteString
+secStmt    = B.pack "\t.section\t"
+infoSec    = B.pack infoSection
 newInfoSec = B.pack "\n\t.text"
 newLine    = B.pack "\n"
 jmpInst    = B.pack "\n\tjmp"
@@ -58,25 +61,30 @@ llvmFixupAsm f1 f2 = do
 
 {- |
     Here we process the assembly file one function and data
-    defenition at a time. When a function is encountered that
+    definition at a time. When a function is encountered that
     should have a info table we store it in a map. Otherwise
     we print it. When an info table is found we retrieve its
     function from the map and print them both.
 
     For all functions we fix up the stack alignment. We also
-    fix up the section defenition for functions and info tables.
+    fix up the section definition for functions and info tables.
 -}
 fixTables :: Handle -> Handle -> I.IntMap B.ByteString -> IO ()
 fixTables r w m = do
     f <- getFun r B.empty
     if B.null f
        then return ()
-       else let fun   = fixupStack f B.empty
-                (a,b) = B.breakSubstring infoSec fun
-                (x,c) = B.break eolPred b
-                fun'  = a `B.append` newInfoSec `B.append` c
-                n     = readInt $ B.drop infoLen x
-                (bs, m') | B.null b  = ([fun], m)
+       else let fun    = fixupStack f B.empty
+                (a,b)  = B.breakSubstring infoSec fun
+                (a',s) = B.breakEnd eolPred a
+                -- We search for the section header in two parts as it makes
+                -- us portable across OS types and LLVM version types since
+                -- section names are wrapped differently.
+                secHdr = secStmt `B.isPrefixOf` s
+                (x,c)  = B.break eolPred b
+                fun'   = a' `B.append` newInfoSec `B.append` c
+                n      = readInt $ B.takeWhile isDigit $ B.drop infoLen x
+                (bs, m') | B.null b || not secHdr = ([fun], m)
                          | even n    = ([], I.insert n fun' m)
                          | otherwise = case I.lookup (n+1) m of
                                Just xf' -> ([fun',xf'], m)
@@ -96,7 +104,7 @@ getFun r f = do
     Mac OS X requires that the stack be 16 byte aligned when making a function
     call (only really required though when making a call that will pass through
     the dynamic linker). The alignment isn't correctly generated by LLVM as
-    LLVM rightly assumes that the stack wil be aligned to 16n + 12 on entry
+    LLVM rightly assumes that the stack will be aligned to 16n + 12 on entry
     (since the function call was 16 byte aligned and the return address should
     have been pushed, so sub 4). GHC though since it always uses jumps keeps
     the stack 16 byte aligned on both function calls and function entry.
@@ -104,6 +112,11 @@ getFun r f = do
     We correct the alignment here.
 -}
 fixupStack :: B.ByteString -> B.ByteString -> B.ByteString
+
+#if !darwin_TARGET_OS
+fixupStack = const
+
+#else
 fixupStack f f' | B.null f' =
     let -- fixup sub op
         (a, c) = B.breakSubstring spInst f
@@ -132,10 +145,11 @@ fixupStack f f' =
                 then fixupStack b $ f' `B.append` a `B.append` l
                 else fixupStack b $ f' `B.append` a' `B.append` num `B.append`
                                     x `B.append` l
+#endif
 
--- | read an int or error
+-- | 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"
+            | otherwise = error $ "LLvmMangler Cannot read " ++ show str
+                                ++ " as it's not an Int"
 

compiler/main/DriverPhases.hs

@@ -143,11 +143,7 @@ nextPhase (Hsc   _)     = HCc
 nextPhase SplitMangle   = As
 nextPhase As            = SplitAs
 nextPhase LlvmOpt       = LlvmLlc
-#if darwin_TARGET_OS
 nextPhase LlvmLlc       = LlvmMangle
-#else
-nextPhase LlvmLlc       = As
-#endif
 nextPhase LlvmMangle    = As
 nextPhase SplitAs       = MergeStub
 nextPhase Ccpp          = As

compiler/main/DriverPipeline.hs

@@ -1307,22 +1307,18 @@ runPhase LlvmOpt input_fn dflags
         -- fix up some pretty big deficiencies in the code we generate
         llvmOpts = ["-mem2reg", "-O1", "-O2"]
 
-
 -----------------------------------------------------------------------------
 -- LlvmLlc phase
 
 runPhase LlvmLlc input_fn dflags
   = do
     let lc_opts = getOpts dflags opt_lc
-    let opt_lvl = max 0 (min 2 $ optLevel dflags)
-    let nphase = if cTargetOS == OSX
-                 then LlvmMangle
-                 else As
-    let rmodel | opt_PIC        = "pic"
+        opt_lvl = max 0 (min 2 $ optLevel dflags)
+        rmodel | opt_PIC        = "pic"
                | not opt_Static = "dynamic-no-pic"
                | otherwise      = "static"
 
-    output_fn <- phaseOutputFilename nphase
+    output_fn <- phaseOutputFilename LlvmMangle
 
     io $ SysTools.runLlvmLlc dflags
                 ([ SysTools.Option (llvmOpts !! opt_lvl),
@@ -1331,13 +1327,13 @@ runPhase LlvmLlc input_fn dflags
                     SysTools.Option "-o", SysTools.FileOption "" output_fn]
                 ++ map SysTools.Option lc_opts)
 
-    return (nphase, output_fn)
+    return (LlvmMangle, output_fn)
   where
+        -- Bug in LLVM at O3 on OSX.
         llvmOpts = if cTargetOS == OSX
                    then ["-O1", "-O2", "-O2"]
                    else ["-O1", "-O2", "-O3"]
 
-
 -----------------------------------------------------------------------------
 -- LlvmMangle phase
 

compiler/main/SysTools.lhs

@@ -238,7 +238,7 @@ initSysTools mbMinusB
                 ld_prog  = gcc_prog
                 ld_args  = gcc_args
 
-        -- figure out llvm location. (TODO: Acutally implement).
+        -- We just assume on command line
         ; let lc_prog = "llc"
               lo_prog = "opt"