Commit e5477638 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Merge remote branch 'origin/master'

parents d4780d48 6ac1eeb5
......@@ -137,8 +137,7 @@ data Var
-- Identical to the Unique in the name,
-- cached here for speed
varType :: Kind, -- ^ The type or kind of the 'Var' in question
isCoercionVar :: Bool
}
isCoercionVar :: Bool }
| TcTyVar { -- Used only during type inference
-- Used for kind variables during
......
This diff is collapsed.
......@@ -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"
{-# 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
......@@ -19,18 +23,25 @@ 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"
spInst = B.pack ", %esp\n"
jmpInst = B.pack "\n\tjmp"
infoLen, spFix, labelStart :: Int
infoLen = B.length infoSec
spFix = 4
infoLen, labelStart, spFix :: Int
infoLen = B.length infoSec
labelStart = B.length jmpInst
#if x86_64_TARGET_ARCH
spInst = B.pack ", %rsp\n"
spFix = 8
#else
spInst = B.pack ", %esp\n"
spFix = 4
#endif
-- Search Predicates
eolPred, dollarPred, commaPred :: Char -> Bool
eolPred = ((==) '\n')
......@@ -50,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)
......@@ -88,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.
......@@ -96,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
......@@ -124,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"
......@@ -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
......
......@@ -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
......
......@@ -1103,12 +1103,13 @@ parseDynamicFlags_ dflags0 args pkg_flags = do
when (not (null errs)) $ ghcError $ errorsToGhcException errs
let (pic_warns, dflags2)
| not (cTargetArch == X86_64 && cTargetOS == Linux) &&
| not (cTargetArch == X86_64 && (cTargetOS == Linux || cTargetOS == OSX)) &&
(not opt_Static || opt_PIC) &&
hscTarget dflags1 == HscLlvm
= ([L noSrcSpan $ "Warning: -fllvm is incompatible with -fPIC and -"
++ "dynamic on this platform;\n"
++ " using " ++ showHscTargetFlag defaultObjectTarget ++ " instead"],
= ([L noSrcSpan $ "Warning: -fllvm is incompatible with -fPIC and "
++ "-dynamic on this platform;\n"
++ " using "
++ showHscTargetFlag defaultObjectTarget ++ " instead"],
dflags1{ hscTarget = defaultObjectTarget })
| otherwise = ([], dflags1)
......
......@@ -15,11 +15,11 @@ module GhcMonad (
reflectGhc, reifyGhc,
getSessionDynFlags,
liftIO,
Session(..), withSession, modifySession, withTempSession,
Session(..), withSession, modifySession, withTempSession,
-- ** Warnings
logWarnings, printException, printExceptionAndWarnings,
WarnErrLogger, defaultWarnErrLogger
WarnErrLogger, defaultWarnErrLogger
) where
import MonadUtils
......
......@@ -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"
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment