Commit a948fe83 authored by Peter Wortmann's avatar Peter Wortmann Committed by dterei

Major Llvm refactoring

This combined patch reworks the LLVM backend in a number of ways:

1. Most prominently, we introduce a LlvmM monad carrying the contents of
   the old LlvmEnv around. This patch completely removes LlvmEnv and
   refactors towards standard library monad combinators wherever possible.

2. Support for streaming - we can now generate chunks of Llvm for Cmm as
   it comes in. This might improve our speed.

3. To allow streaming, we need a more flexible way to handle forward
   references. The solution (getGlobalPtr) unifies LlvmCodeGen.Data
   and getHsFunc as well.

4. Skip alloca-allocation for registers that are actually never written.
   LLVM will automatically eliminate these, but output is smaller and
   friendlier to human eyes this way.

5. We use LlvmM to collect references for llvm.used. This allows places
   other than cmmProcLlvmGens to generate entries.
parent fa6cbdfb
......@@ -623,6 +623,8 @@ data LlvmLinkageType
-- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM
-- assembly.
| External
-- | Symbol is private to the module and should not appear in the symbol table
| Private
deriving (Eq)
instance Outputable LlvmLinkageType where
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
......@@ -3,7 +3,7 @@
--
module LlvmCodeGen.Data (
genLlvmData, resolveLlvmDatas, resolveLlvmData
genLlvmData
) where
#include "HsVersions.h"
......@@ -18,8 +18,6 @@ import Cmm
import FastString
import qualified Outputable
import Data.List (foldl')
-- ----------------------------------------------------------------------------
-- * Constants
--
......@@ -32,43 +30,23 @@ structStr = fsLit "_struct"
-- * Top level
--
-- | Pass a CmmStatic section to an equivalent Llvm code. Can't
-- complete this completely though as we need to pass all CmmStatic
-- sections before all references can be resolved. This last step is
-- done by 'resolveLlvmData'.
genLlvmData :: LlvmEnv -> (Section, CmmStatics) -> LlvmUnresData
genLlvmData env (sec, Statics lbl xs) =
let dflags = getDflags env
static = map genData xs
label = strCLabel_llvm env lbl
types = map getStatTypes static
getStatTypes (Left x) = cmmToLlvmType $ cmmLitType dflags x
getStatTypes (Right x) = getStatType x
-- | Pass a CmmStatic section to an equivalent Llvm code.
genLlvmData :: (Section, CmmStatics) -> LlvmM LlvmData
genLlvmData (sec, Statics lbl xs) = do
label <- strCLabel_llvm lbl
static <- mapM genData xs
let types = map getStatType static
strucTy = LMStruct types
alias = LMAlias ((label `appendFS` structStr), strucTy)
in (lbl, sec, alias, static)
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 ([], [])
struct = Just $ LMStaticStruc static alias
label = strCLabel_llvm env lbl
link = if (externallyVisibleCLabel lbl)
then ExternallyVisible else Internal
const = if isSecConstant sec then Constant else Global
glob = LMGlobalVar label alias link Nothing Nothing const
in (env', ((LMGlobal glob struct):refs, [alias]))
return ([LMGlobal glob struct], [alias])
-- | Should a data in this section be considered constant
isSecConstant :: Section -> Bool
......@@ -81,81 +59,20 @@ isSecConstant UninitialisedData = False
isSecConstant (OtherSection _) = False
-- ----------------------------------------------------------------------------
-- ** Resolve Data/CLabel references
--
-- | Resolve data list
resDatas :: LlvmEnv -> [UnresStatic] -> ([LlvmStatic], [LMGlobal])
-> (LlvmEnv, [LlvmStatic], [LMGlobal])
resDatas env [] (stats, glob)
= (env, stats, glob)
resDatas env (cmm:rest) (stats, globs)
= let (env', nstat, nglob) = resData env cmm
in resDatas env' rest (stats ++ [nstat], globs ++ nglob)
-- | Resolve an individual static label if it needs to be.
--
-- We check the 'LlvmEnv' to see if the reference has been defined in this
-- 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, [LMGlobal])
resData env (Right stat) = (env, stat, [])
resData env (Left cmm@(CmmLabel l)) =
let dflags = getDflags env
label = strCLabel_llvm env l
ty = funLookup label env
lmty = cmmToLlvmType $ cmmLitType dflags cmm
in case ty of
-- Make generic external label defenition and then pointer to it
Nothing ->
let glob@(LMGlobal var _) = genStringLabelRef dflags label
env' = funInsert label (pLower $ getVarType var) env
ptr = LMStaticPointer var
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 Global
ptr = LMStaticPointer var
in (env, LMPtoI ptr lmty, [])
resData env (Left (CmmLabelOff label off)) =
let dflags = getDflags env
(env', var, glob) = resData env (Left (CmmLabel label))
offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)
in (env', LMAdd var offset, glob)
resData env (Left (CmmLabelDiffOff l1 l2 off)) =
let dflags = getDflags env
(env1, var1, glob1) = resData env (Left (CmmLabel l1))
(env2, var2, glob2) = resData env1 (Left (CmmLabel l2))
var = LMSub var1 var2
offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)
in (env2, LMAdd var offset, glob1 ++ glob2)
resData _ _ = panic "resData: Non CLabel expr as left type!"
-- ----------------------------------------------------------------------------
-- * Generate static data
--
-- | Handle static data
genData :: CmmStatic -> UnresStatic
genData :: CmmStatic -> LlvmM LlvmStatic
genData (CmmString str) =
genData (CmmString str) = do
let v = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) str
ve = v ++ [LMStaticLit $ LMIntLit 0 i8]
in Right $ LMStaticArray ve (LMArray (length ve) i8)
return $ LMStaticArray ve (LMArray (length ve) i8)
genData (CmmUninitialised bytes)
= Right $ LMUninitType (LMArray bytes i8)
= return $ LMUninitType (LMArray bytes i8)
genData (CmmStaticLit lit)
= genStaticLit lit
......@@ -164,27 +81,47 @@ genData (CmmStaticLit lit)
--
-- Will either generate the code or leave it unresolved if it is a 'CLabel'
-- which isn't yet known.
genStaticLit :: CmmLit -> UnresStatic
genStaticLit :: CmmLit -> LlvmM LlvmStatic
genStaticLit (CmmInt i w)
= Right $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w))
= return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w))
genStaticLit (CmmFloat r w)
= Right $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w))
= return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w))
genStaticLit (CmmVec ls)
= Right $ LMStaticLit (LMVectorLit (map toLlvmLit ls))
= do sls <- mapM toLlvmLit ls
return $ LMStaticLit (LMVectorLit sls)
where
toLlvmLit :: CmmLit -> LlvmLit
toLlvmLit lit = case genStaticLit lit of
Right (LMStaticLit llvmLit) -> llvmLit
_ -> panic "genStaticLit"
toLlvmLit :: CmmLit -> LlvmM LlvmLit
toLlvmLit lit = do
slit <- genStaticLit lit
case slit of
LMStaticLit llvmLit -> return llvmLit
_ -> panic "genStaticLit"
-- Leave unresolved, will fix later
genStaticLit c@(CmmLabel _ ) = Left $ c
genStaticLit c@(CmmLabelOff _ _) = Left $ c
genStaticLit c@(CmmLabelDiffOff _ _ _) = Left $ c
genStaticLit cmm@(CmmLabel l) = do
var <- getGlobalPtr =<< strCLabel_llvm l
dflags <- getDynFlags
let ptr = LMStaticPointer var
lmty = cmmToLlvmType $ cmmLitType dflags cmm
return $ LMPtoI ptr lmty
genStaticLit (CmmLabelOff label off) = do
dflags <- getDynFlags
var <- genStaticLit (CmmLabel label)
let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)
return $ LMAdd var offset
genStaticLit (CmmLabelDiffOff l1 l2 off) = do
dflags <- getDynFlags
var1 <- genStaticLit (CmmLabel l1)
var2 <- genStaticLit (CmmLabel l2)
let var = LMSub var1 var2
offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)
return $ LMAdd var offset
genStaticLit (CmmBlock b) = Left $ CmmLabel $ infoTblLbl b
genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b
genStaticLit (CmmHighStackMark)
= panic "genStaticLit: CmmHighStackMark unsupported!"
......
......@@ -11,7 +11,6 @@ module LlvmCodeGen.Ppr (
import Llvm
import LlvmCodeGen.Base
import LlvmCodeGen.Data
import LlvmCodeGen.Regs
import CLabel
import Cmm
......@@ -28,12 +27,7 @@ import Unique
-- | Header code for LLVM modules
pprLlvmHeader :: SDoc
pprLlvmHeader = sdocWithDynFlags $ \dflags ->
moduleLayout
$+$ text ""
$+$ ppLlvmFunctionDecls (map snd (ghcInternalFunctions dflags))
$+$ ppLlvmMetas stgTBAA
$+$ text ""
pprLlvmHeader = moduleLayout
-- | LLVM module layout description for the host target
......@@ -75,63 +69,61 @@ moduleLayout = sdocWithPlatform $ \platform ->
-- | Pretty print LLVM data code
pprLlvmData :: LlvmData -> SDoc
pprLlvmData (globals, types) =
let tryConst (LMGlobal v (Just s)) = ppLlvmGlobal (LMGlobal v $ Just s)
tryConst g@(LMGlobal _ Nothing) = ppLlvmGlobal g
ppLlvmTys (LMAlias a) = ppLlvmAlias a
let ppLlvmTys (LMAlias a) = ppLlvmAlias a
ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f
ppLlvmTys _other = empty
types' = vcat $ map ppLlvmTys types
globals' = vcat $ map tryConst globals
globals' = ppLlvmGlobals globals
in types' $+$ globals'
-- | Pretty print LLVM code
pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (SDoc, [LlvmVar])
pprLlvmCmmDecl _ _ (CmmData _ lmdata)
= (vcat $ map pprLlvmData lmdata, [])
pprLlvmCmmDecl :: Int -> LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
pprLlvmCmmDecl _ (CmmData _ lmdata)
= return (vcat $ map pprLlvmData lmdata, [])
pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl live (ListGraph blks))
= let (idoc, ivar) = case mb_info of
Nothing -> (empty, [])
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 env count info_lbl (Statics entry_lbl dat)
in (idoc $+$ (
let sec = mkLayoutSection (count + 1)
(lbl',sec') = case mb_info of
-> 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'
link = if externallyVisibleCLabel lbl'
then ExternallyVisible
else Internal
lmblocks = map (\(BasicBlock id stmts) ->
lmblocks = map (\(BasicBlock id stmts) ->
LlvmBlock (getUnique id) stmts) blks
fun = mkLlvmFunc env live lbl' link sec' lmblocks
in ppLlvmFunction fun
), ivar)
fun <- mkLlvmFunc live lbl' link sec' lmblocks
return (idoc $+$ ppLlvmFunction fun, ivar)
-- | Pretty print CmmStatic
pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (SDoc, [LlvmVar])
pprInfoTable env count info_lbl stat
= let dflags = getDflags env
unres = genLlvmData env (Text, stat)
(_, (ldata, ltypes)) = resolveLlvmData env unres
setSection (LMGlobal (LMGlobalVar _ ty l _ _ c) d)
= let sec = mkLayoutSection count
ilabel = strCLabel_llvm env info_lbl
`appendFS` fsLit iTableSuf
gv = LMGlobalVar ilabel ty l sec (llvmInfAlign dflags) c
v = if l == Internal then [gv] else []
in (LMGlobal gv d, v)
setSection v = (v,[])
(ldata', llvmUsed) = setSection (last ldata)
in if length ldata /= 1
pprInfoTable :: Int -> CLabel -> CmmStatics -> LlvmM (SDoc, [LlvmVar])
pprInfoTable count info_lbl stat
= do (ldata, ltypes) <- genLlvmData (Text, stat)
dflags <- getDynFlags
let 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
v = if l == Internal then [gv] else []
funInsert ilabel ty
return (LMGlobal gv d, v)
setSection v = return (v,[])
(ldata', llvmUsed) <- setSection (last ldata)
if length ldata /= 1
then Outputable.panic "LlvmCodeGen.Ppr: invalid info table!"
else (pprLlvmData ([ldata'], ltypes), llvmUsed)
else return (pprLlvmData ([ldata'], ltypes), llvmUsed)
-- | We generate labels for info tables by converting them to the same label
......
......@@ -4,7 +4,7 @@
module LlvmCodeGen.Regs (
lmGlobalRegArg, lmGlobalRegVar, alwaysLive,
stgTBAA, top, base, stack, heap, rx, other, tbaa, getTBAA
stgTBAA, baseN, stackN, heapN, rxN, otherN, tbaa, getTBAA
) where
#include "HsVersions.h"
......@@ -15,6 +15,7 @@ import CmmExpr
import DynFlags
import FastString
import Outputable ( panic )
import Unique
-- | Get the LlvmVar function variable storing the real register
lmGlobalRegVar :: DynFlags -> GlobalReg -> LlvmVar
......@@ -76,48 +77,38 @@ lmGlobalReg dflags suf reg
alwaysLive :: [GlobalReg]
alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node]
-- | STG Type Based Alias Analysis metadata
stgTBAA :: [MetaDecl]
-- | STG Type Based Alias Analysis hierarchy
stgTBAA :: [(Unique, LMString, Maybe Unique)]
stgTBAA
= [ MetaUnamed topN $ MetaStr (fsLit "top")
, MetaUnamed stackN $ MetaStruct [MetaStr (fsLit "stack"), MetaNode topN]
, MetaUnamed heapN $ MetaStruct [MetaStr (fsLit "heap"), MetaNode topN]
, MetaUnamed rxN $ MetaStruct [MetaStr (fsLit "rx"), MetaNode heapN]
, MetaUnamed baseN $ MetaStruct [MetaStr (fsLit "base"), MetaNode topN]
= [ (topN, fsLit "top", Nothing)
, (stackN, fsLit "stack", Just topN)
, (heapN, fsLit "heap", Just topN)
, (rxN, fsLit "rx", Just heapN)
, (baseN, fsLit "base", Just topN)
-- FIX: Not 100% sure about 'others' place. Might need to be under 'heap'.
-- OR I think the big thing is Sp is never aliased, so might want
-- to change the hieracy to have Sp on its own branch that is never
-- aliased (e.g never use top as a TBAA node).
, MetaUnamed otherN $ MetaStruct [MetaStr (fsLit "other"), MetaNode topN]
, (otherN, fsLit "other", Just topN)
]
-- | Id values
topN, stackN, heapN, rxN, baseN, otherN:: Int
topN = 0
stackN = 1
heapN = 2
rxN = 3
baseN = 4
otherN = 5
-- | The various TBAA types
top, heap, stack, rx, base, other :: MetaAnnot
top = MetaAnnot tbaa (MetaNode topN)
heap = MetaAnnot tbaa (MetaNode heapN)
stack = MetaAnnot tbaa (MetaNode stackN)
rx = MetaAnnot tbaa (MetaNode rxN)
base = MetaAnnot tbaa (MetaNode baseN)
other = MetaAnnot tbaa (MetaNode otherN)
topN, stackN, heapN, rxN, baseN, otherN :: Unique
topN = getUnique (fsLit "LlvmCodeGen.Regs.topN")
stackN = getUnique (fsLit "LlvmCodeGen.Regs.stackN")
heapN = getUnique (fsLit "LlvmCodeGen.Regs.heapN")
rxN = getUnique (fsLit "LlvmCodeGen.Regs.rxN")
baseN = getUnique (fsLit "LlvmCodeGen.Regs.baseN")
otherN = getUnique (fsLit "LlvmCodeGen.Regs.otherN")
-- | The TBAA metadata identifier
tbaa :: LMString
tbaa = fsLit "tbaa"
-- | Get the correct TBAA metadata information for this register type
getTBAA :: GlobalReg -> MetaAnnot
getTBAA BaseReg = base
getTBAA Sp = stack
getTBAA Hp = heap
getTBAA (VanillaReg _ _) = rx
getTBAA _ = top
getTBAA :: GlobalReg -> Unique
getTBAA BaseReg = baseN
getTBAA Sp = stackN
getTBAA Hp = heapN
getTBAA (VanillaReg _ _) = rxN
getTBAA _ = topN
......@@ -168,13 +168,9 @@ outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()
outputLlvm dflags filenm cmm_stream
= do ncg_uniqs <- mkSplitUniqSupply 'n'
-- ToDo: make the LLVM backend consume the C-- incrementally,
-- by pushing the cmm_stream inside (c.f. nativeCodeGen)
rawcmms <- Stream.collect cmm_stream
{-# SCC "llvm_output" #-} doOutput filenm $
\f -> {-# SCC "llvm_CodeGen" #-}
llvmCodeGen dflags f ncg_uniqs rawcmms
llvmCodeGen dflags f ncg_uniqs cmm_stream
\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