Commit 9911ec55 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Merge branch 'master' of http://darcs.haskell.org/ghc

parents 1a8c2bb0 9a0adc0b
......@@ -447,9 +447,6 @@ pprLit platform lit = case lit of
-- WARNING:
-- * the lit must occur in the info table clbl2
-- * clbl1 must be an SRT, a slow entry point or a large bitmap
-- The Mangler is expected to convert any reference to an SRT,
-- a slow entry point or a large bitmap
-- from an info table to an offset.
-> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i
where
......
......@@ -24,7 +24,7 @@ module CgInfoTbls (
cmmGetClosureType,
infoTable, infoTableClosureType,
infoTablePtrs, infoTableNonPtrs,
funInfoTable, makeRelativeRefTo
funInfoTable
) where
......@@ -386,25 +386,3 @@ emitInfoTableAndCode
emitInfoTableAndCode entry_ret_lbl info args blocks
= emitProc info entry_ret_lbl args blocks
-------------------------------------------------------------------------
--
-- Position independent code
--
-------------------------------------------------------------------------
-- In order to support position independent code, we mustn't put absolute
-- references into read-only space. Info tables in the tablesNextToCode
-- case must be in .text, which is read-only, so we doctor the CmmLits
-- to use relative offsets instead.
-- Note that this is done even when the -fPIC flag is not specified,
-- as we want to keep binary compatibility between PIC and non-PIC.
makeRelativeRefTo :: CLabel -> CmmLit -> CmmLit
makeRelativeRefTo info_lbl (CmmLabel lbl)
| tablesNextToCode
= CmmLabelDiffOff lbl info_lbl 0
makeRelativeRefTo info_lbl (CmmLabelOff lbl off)
| tablesNextToCode
= CmmLabelDiffOff lbl info_lbl off
makeRelativeRefTo _ lit = lit
......@@ -36,7 +36,8 @@ import System.IO
llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
llvmCodeGen dflags h us cmms
= let cmm = concat cmms
(cdata,env) = foldr split ([],initLlvmEnv (targetPlatform dflags)) cmm
(cdata,env) = {-# SCC "llvm_split" #-}
foldr split ([],initLlvmEnv (targetPlatform dflags)) cmm
split (CmmData s d' ) (d,e) = ((s,d'):d,e)
split (CmmProc i l _) (d,e) =
let lbl = strCLabel_llvm env $ case i of
......@@ -49,8 +50,10 @@ llvmCodeGen dflags h us cmms
bufh <- newBufHandle h
Prt.bufLeftRender bufh $ pprLlvmHeader
ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
env' <- cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata []
cmmProcLlvmGens dflags bufh us env' cmm 1 []
env' <- {-# SCC "llvm_datas_gen" #-}
cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata []
{-# SCC "llvm_procs_gen" #-}
cmmProcLlvmGens dflags bufh us env' cmm 1 []
bFlush bufh
return ()
......@@ -62,17 +65,24 @@ cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)]
-> [LlvmUnresData] -> IO ( LlvmEnv )
cmmDataLlvmGens dflags h env [] lmdata
= let (env', lmdata') = resolveLlvmDatas env lmdata []
lmdoc = Prt.vcat $ map pprLlvmData lmdata'
= let (env', lmdata') = {-# SCC "llvm_resolve" #-}
resolveLlvmDatas env lmdata
lmdoc = {-# SCC "llvm_data_ppr" #-}
Prt.vcat $ map pprLlvmData lmdata'
in do
dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc lmdoc
Prt.bufLeftRender h lmdoc
{-# SCC "llvm_data_out" #-}
Prt.bufLeftRender h lmdoc
return env'
cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
= let lmdata'@(l, _, ty, _) = genLlvmData env cmm
env' = funInsert (strCLabel_llvm env l) ty env
in cmmDataLlvmGens dflags h env' cmms (lmdata ++ [lmdata'])
= let lm@(l, _, ty, _) = {-# SCC "llvm_data_gen" #-}
genLlvmData env cmm
env' = {-# SCC "llvm_data_insert" #-}
funInsert (strCLabel_llvm env l) ty env
lmdata' = {-# SCC "llvm_data_append" #-}
lm:lmdata
in cmmDataLlvmGens dflags h env' cmms lmdata'
-- -----------------------------------------------------------------------------
......@@ -93,7 +103,8 @@ cmmProcLlvmGens _ h _ _ [] _ ivars
usedArray = LMStaticArray (map cast ivars') ty
lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
(Just $ fsLit "llvm.metadata") Nothing False, Just usedArray)
in Prt.bufLeftRender h $ pprLlvmData ([lmUsed], [])
in Prt.bufLeftRender h $ {-# SCC "llvm_used_ppr" #-}
pprLlvmData ([lmUsed], [])
cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
= cmmProcLlvmGens dflags h us env cmms count ivars
......@@ -104,7 +115,7 @@ cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivar
cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do
(us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm
Prt.bufLeftRender h $ Prt.vcat docs
Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-} Prt.vcat docs
cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars)
......@@ -113,13 +124,15 @@ cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmDecl
-> IO ( UniqSupply, LlvmEnv, [LlvmCmmDecl] )
cmmLlvmGen dflags us env cmm = do
-- rewrite assignments to global regs
let fixed_cmm = fixStgRegisters cmm
let fixed_cmm = {-# SCC "llvm_fix_regs" #-}
fixStgRegisters cmm
dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
(pprCmmGroup (targetPlatform dflags) [fixed_cmm])
-- generate llvm code from cmm
let ((env', llvmBC), usGen) = initUs us $ genLlvmProc env fixed_cmm
let ((env', llvmBC), usGen) = {-# SCC "llvm_proc_gen" #-}
initUs us $ genLlvmProc env fixed_cmm
dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
(vcat $ map (docToSDoc . fst . pprLlvmCmmDecl env' 0) llvmBC)
......
......@@ -158,17 +158,26 @@ initLlvmEnv platform = LlvmEnv (emptyUFM, emptyUFM, defaultLlvmVersion, platform
-- | Clear variables from the environment.
clearVars :: LlvmEnv -> LlvmEnv
clearVars (LlvmEnv (e1, _, n, p)) = LlvmEnv (e1, emptyUFM, n, p)
clearVars (LlvmEnv (e1, _, n, p)) = {-# SCC "llvm_env_clear" #-}
LlvmEnv (e1, emptyUFM, n, p)
-- | Insert functions into the environment.
varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
varInsert s t (LlvmEnv (e1, e2, n, p)) = LlvmEnv (e1, addToUFM e2 s t, n, p)
funInsert s t (LlvmEnv (e1, e2, n, p)) = LlvmEnv (addToUFM e1 s t, e2, n, p)
varInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
varInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_vinsert" #-}
LlvmEnv (e1, addToUFM e2 s t, n, p)
funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
funInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_finsert" #-}
LlvmEnv (addToUFM e1 s t, e2, n, p)
-- | Lookup functions in the environment.
varLookup, funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
varLookup s (LlvmEnv (_, e2, _, _)) = lookupUFM e2 s
funLookup s (LlvmEnv (e1, _, _, _)) = lookupUFM e1 s
varLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
varLookup s (LlvmEnv (_, e2, _, _)) = {-# SCC "llvm_env_vlookup" #-}
lookupUFM e2 s
funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
funLookup s (LlvmEnv (e1, _, _, _)) = {-# SCC "llvm_env_flookup" #-}
lookupUFM e1 s
-- | Get the LLVM version we are generating code for
getLlvmVer :: LlvmEnv -> LlvmVersion
......@@ -188,8 +197,8 @@ getLlvmPlatform (LlvmEnv (_, _, _, p)) = p
-- | Pretty print a 'CLabel'.
strCLabel_llvm :: LlvmEnv -> CLabel -> LMString
strCLabel_llvm env l
= (fsLit . show . llvmSDoc . pprCLabel (getLlvmPlatform env)) l
strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-}
(fsLit . show . llvmSDoc . pprCLabel (getLlvmPlatform env)) l
-- | Create an external definition for a 'CLabel' defined in another module.
genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal
......@@ -201,7 +210,6 @@ genStringLabelRef cl
= let ty = LMPointer $ LMArray 0 llvmWord
in (LMGlobalVar cl ty External Nothing Nothing False, Nothing)
-- ----------------------------------------------------------------------------
-- * Misc
--
......
......@@ -28,7 +28,6 @@ import Unique
import Util
import Data.List ( partition )
import Control.Monad ( liftM )
type LlvmStatements = OrdList LlvmStatement
......@@ -57,8 +56,7 @@ basicBlocksCodeGen env ([]) (blocks, tops)
= do let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
let allocs' = concat allocs
let ((BasicBlock id fstmts):rblks) = blocks'
fplog <- funPrologue
let fblocks = (BasicBlock id (fplog ++ allocs' ++ fstmts)):rblks
let fblocks = (BasicBlock id $ funPrologue ++ allocs' ++ fstmts):rblks
return (env, fblocks, tops)
basicBlocksCodeGen env (block:blocks) (lblocks', ltops')
......@@ -1189,13 +1187,13 @@ genLit _ CmmHighStackMark
--
-- | Function prologue. Load STG arguments into variables for function.
funPrologue :: UniqSM [LlvmStatement]
funPrologue = liftM concat $ mapM getReg activeStgRegs
funPrologue :: [LlvmStatement]
funPrologue = concat $ map getReg activeStgRegs
where getReg rr =
let reg = lmGlobalRegVar rr
arg = lmGlobalRegArg rr
let reg = lmGlobalRegVar rr
arg = lmGlobalRegArg rr
alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
in return [alloc, Store arg reg]
in [alloc, Store arg reg]
-- | Function epilogue. Load STG variables to use as argument for call.
......
......@@ -18,8 +18,7 @@ import OldCmm
import FastString
import qualified Outputable
import Data.Maybe
import Data.List (foldl')
-- ----------------------------------------------------------------------------
-- * Constants
......@@ -51,37 +50,33 @@ genLlvmData env (sec, Statics lbl xs) =
in (lbl, sec, alias, static)
resolveLlvmDatas :: LlvmEnv -> [LlvmUnresData] -> [LlvmData]
-> (LlvmEnv, [LlvmData])
resolveLlvmDatas env [] ldata
= (env, ldata)
resolveLlvmDatas env (udata : rest) ldata
= let (env', ndata) = resolveLlvmData env udata
in resolveLlvmDatas env' rest (ldata ++ [ndata])
resolveLlvmDatas :: LlvmEnv -> [LlvmUnresData] -> (LlvmEnv, [LlvmData])
resolveLlvmDatas env ldata
= foldl' res (env, []) ldata
where res (e, xs) ll =
let (e', nd) = resolveLlvmData e ll
in (e', nd:xs)
-- | Fix up CLabel references now that we should have passed all CmmData.
resolveLlvmData :: LlvmEnv -> LlvmUnresData -> (LlvmEnv, LlvmData)
resolveLlvmData env (lbl, sec, alias, unres) =
let (env', static, refs) = resDatas env unres ([], [])
refs' = catMaybes refs
struct = Just $ LMStaticStruc static alias
label = strCLabel_llvm env lbl
link = if (externallyVisibleCLabel lbl)
then ExternallyVisible else Internal
const = isSecConstant sec
glob = LMGlobalVar label alias link Nothing Nothing const
in (env', (refs' ++ [(glob, struct)], [alias]))
in (env', ((glob,struct):refs, [alias]))
-- | Should a data in this section be considered constant
isSecConstant :: Section -> Bool
isSecConstant Text = True
isSecConstant Data = False
isSecConstant ReadOnlyData = True
isSecConstant RelocatableReadOnlyData = True
isSecConstant UninitialisedData = False
isSecConstant ReadOnlyData16 = True
isSecConstant Data = False
isSecConstant UninitialisedData = False
isSecConstant (OtherSection _) = False
......@@ -90,13 +85,13 @@ isSecConstant (OtherSection _) = False
--
-- | Resolve data list
resDatas :: LlvmEnv -> [UnresStatic] -> ([LlvmStatic], [Maybe LMGlobal])
-> (LlvmEnv, [LlvmStatic], [Maybe LMGlobal])
resDatas :: LlvmEnv -> [UnresStatic] -> ([LlvmStatic], [LMGlobal])
-> (LlvmEnv, [LlvmStatic], [LMGlobal])
resDatas env [] (stat, glob)
= (env, stat, glob)
resDatas env [] (stats, glob)
= (env, stats, glob)
resDatas env (cmm : rest) (stats, globs)
resDatas env (cmm:rest) (stats, globs)
= let (env', nstat, nglob) = resData env cmm
in resDatas env' rest (stats ++ [nstat], globs ++ nglob)
......@@ -106,9 +101,9 @@ resDatas env (cmm : rest) (stats, globs)
-- module. If it has we can retrieve its type and make a pointer, otherwise
-- we introduce a generic external definition for the referenced label and
-- then make a pointer.
resData :: LlvmEnv -> UnresStatic -> (LlvmEnv, LlvmStatic, [Maybe LMGlobal])
resData :: LlvmEnv -> UnresStatic -> (LlvmEnv, LlvmStatic, [LMGlobal])
resData env (Right stat) = (env, stat, [Nothing])
resData env (Right stat) = (env, stat, [])
resData env (Left cmm@(CmmLabel l)) =
let label = strCLabel_llvm env l
......@@ -120,14 +115,14 @@ resData env (Left cmm@(CmmLabel l)) =
let glob@(var, _) = genStringLabelRef label
env' = funInsert label (pLower $ getVarType var) env
ptr = LMStaticPointer var
in (env', LMPtoI ptr lmty, [Just glob])
in (env', LMPtoI ptr lmty, [glob])
-- Referenced data exists in this module, retrieve type and make
-- pointer to it.
Just ty' ->
let var = LMGlobalVar label (LMPointer ty')
ExternallyVisible Nothing Nothing False
ptr = LMStaticPointer var
in (env, LMPtoI ptr lmty, [Nothing])
in (env, LMPtoI ptr lmty, [])
resData env (Left (CmmLabelOff label off)) =
let (env', var, glob) = resData env (Left (CmmLabel label))
......@@ -161,7 +156,6 @@ genData (CmmUninitialised bytes)
genData (CmmStaticLit lit)
= genStaticLit lit
-- | Generate Llvm code for a static literal.
--
-- Will either generate the code or leave it unresolved if it is a 'CLabel'
......@@ -183,7 +177,6 @@ genStaticLit (CmmBlock b) = Left $ CmmLabel $ infoTblLbl b
genStaticLit (CmmHighStackMark)
= panic "genStaticLit: CmmHighStackMark unsupported!"
-- -----------------------------------------------------------------------------
-- * Misc
--
......
......@@ -41,7 +41,7 @@ type Section = (B.ByteString, B.ByteString)
-- | Read in assembly file and process
llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO ()
llvmFixupAsm dflags f1 f2 = do
llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} do
showPass dflags "LlVM Mangler"
r <- openBinaryFile f1 ReadMode
w <- openBinaryFile f2 WriteMode
......
......@@ -165,7 +165,9 @@ outputAsm dflags filenm flat_absC
outputLlvm :: DynFlags -> FilePath -> [RawCmmGroup] -> IO ()
outputLlvm dflags filenm flat_absC
= do ncg_uniqs <- mkSplitUniqSupply 'n'
doOutput filenm $ \f -> llvmCodeGen dflags f ncg_uniqs flat_absC
{-# SCC "llvm_output" #-} doOutput filenm $
\f -> {-# SCC "llvm_CodeGen" #-}
llvmCodeGen dflags f ncg_uniqs flat_absC
\end{code}
......
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