summaryrefslogtreecommitdiff
path: root/compiler/llvmGen
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/llvmGen')
-rw-r--r--compiler/llvmGen/Llvm/Types.hs1
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Base.hs32
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Data.hs34
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Ppr.hs2
4 files changed, 61 insertions, 8 deletions
diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs
index 9bcceb599d..6e349d813f 100644
--- a/compiler/llvmGen/Llvm/Types.hs
+++ b/compiler/llvmGen/Llvm/Types.hs
@@ -185,6 +185,7 @@ pprSpecialStatic :: LlvmStatic -> SDoc
pprSpecialStatic (LMBitc v t) =
ppr (pLower t) <> text ", bitcast (" <> ppr v <> text " to " <> ppr t
<> char ')'
+pprSpecialStatic v@(LMStaticPointer x) = ppr (pLower $ getVarType x) <> comma <+> ppr v
pprSpecialStatic stat = ppr stat
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 5ebb7b3830..15101c82ee 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -31,7 +31,7 @@ module LlvmCodeGen.Base (
strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
getGlobalPtr, generateExternDecls,
- aliasify,
+ aliasify, llvmDefLabel
) where
#include "HsVersions.h"
@@ -57,6 +57,7 @@ import UniqSupply
import ErrUtils
import qualified Stream
+import Data.Maybe (fromJust)
import Control.Monad (ap)
-- ----------------------------------------------------------------------------
@@ -376,7 +377,7 @@ ghcInternalFunctions = do
mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]
where
mk n ret args = do
- let n' = fsLit n `appendFS` fsLit "$def"
+ let n' = llvmDefLabel $ fsLit n
decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
FixedArgs (tysToParams args) Nothing
renderLlvm $ ppLlvmFunctionDecl decl
@@ -436,12 +437,17 @@ getGlobalPtr llvmLbl = do
let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing
case m_ty of
-- Directly reference if we have seen it already
- Just ty -> return $ mkGlbVar (llvmLbl `appendFS` fsLit "$def") ty Global
+ Just ty -> return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global
-- Otherwise use a forward alias of it
Nothing -> do
saveAlias llvmLbl
return $ mkGlbVar llvmLbl i8 Alias
+-- | Derive the definition label. It has an identified
+-- structure type.
+llvmDefLabel :: LMString -> LMString
+llvmDefLabel = (`appendFS` fsLit "$def")
+
-- | Generate definitions for aliases forward-referenced by @getGlobalPtr@.
--
-- Must be called at a point where we are sure that no new global definitions
@@ -472,10 +478,28 @@ generateExternDecls = do
-- | Here we take a global variable definition, rename it with a
-- @$def@ suffix, and generate the appropriate alias.
aliasify :: LMGlobal -> LlvmM [LMGlobal]
+-- See note [emit-time elimination of static indirections] in CLabel.
+-- Here we obtain the indirectee's precise type and introduce
+-- fresh aliases to both the precise typed label (lbl$def) and the i8*
+-- typed (regular) label of it with the matching new names.
+aliasify (LMGlobal (LMGlobalVar lbl ty@LMAlias{} link sect align Alias)
+ (Just orig)) = do
+ let defLbl = llvmDefLabel lbl
+ LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig
+ defOrigLbl = llvmDefLabel origLbl
+ orig' = LMStaticPointer (LMGlobalVar origLbl i8Ptr oLnk Nothing Nothing Alias)
+ origType <- funLookup origLbl
+ let defOrig = LMBitc (LMStaticPointer (LMGlobalVar defOrigLbl
+ (pLift $ fromJust origType) oLnk
+ Nothing Nothing Alias))
+ (pLift ty)
+ pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig)
+ , LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig')
+ ]
aliasify (LMGlobal var val) = do
let LMGlobalVar lbl ty link sect align const = var
- defLbl = lbl `appendFS` fsLit "$def"
+ defLbl = llvmDefLabel lbl
defVar = LMGlobalVar defLbl ty Internal sect align const
defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const
diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs
index cabfe76762..3651a88cc6 100644
--- a/compiler/llvmGen/LlvmCodeGen/Data.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Data.hs
@@ -32,12 +32,41 @@ import qualified Data.ByteString as BS
structStr :: LMString
structStr = fsLit "_struct"
+-- | The LLVM visibility of the label
+linkage :: CLabel -> LlvmLinkageType
+linkage lbl = if externallyVisibleCLabel lbl
+ then ExternallyVisible else Internal
+
-- ----------------------------------------------------------------------------
-- * Top level
--
-- | Pass a CmmStatic section to an equivalent Llvm code.
genLlvmData :: (Section, CmmStatics) -> LlvmM LlvmData
+-- See note [emit-time elimination of static indirections] in CLabel.
+genLlvmData (_, Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
+ | lbl == mkIndStaticInfoLabel
+ , let labelInd (CmmLabelOff l _) = Just l
+ labelInd (CmmLabel l) = Just l
+ labelInd _ = Nothing
+ , Just ind' <- labelInd ind
+ , alias `mayRedirectTo` ind' = do
+ label <- strCLabel_llvm alias
+ label' <- strCLabel_llvm ind'
+ let link = linkage alias
+ link' = linkage ind'
+ -- the LLVM type we give the alias is an empty struct type
+ -- but it doesn't really matter, as the pointer is only
+ -- used for (bit/int)casting.
+ tyAlias = LMAlias (label `appendFS` structStr, LMStructU [])
+
+ aliasDef = LMGlobalVar label tyAlias link Nothing Nothing Alias
+ -- we don't know the type of the indirectee here
+ indType = panic "will be filled by 'aliasify', later"
+ orig = LMStaticPointer $ LMGlobalVar label' indType link' Nothing Nothing Alias
+
+ pure ([LMGlobal aliasDef $ Just orig], [tyAlias])
+
genLlvmData (sec, Statics lbl xs) = do
label <- strCLabel_llvm lbl
static <- mapM genData xs
@@ -45,11 +74,10 @@ genLlvmData (sec, Statics lbl xs) = do
let types = map getStatType static
strucTy = LMStruct types
- tyAlias = LMAlias ((label `appendFS` structStr), strucTy)
+ tyAlias = LMAlias (label `appendFS` structStr, strucTy)
struct = Just $ LMStaticStruc static tyAlias
- link = if (externallyVisibleCLabel lbl)
- then ExternallyVisible else Internal
+ link = linkage lbl
align = case sec of
Section CString _ -> Just 1
_ -> Nothing
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index c1378aa1fd..3f29133e59 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -71,7 +71,7 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
let fun = LlvmFunction funDec funArgs llvmStdFunAttrs funSect
prefix lmblocks
name = decName $ funcDecl fun
- defName = name `appendFS` fsLit "$def"
+ defName = llvmDefLabel name
funcDecl' = (funcDecl fun) { decName = defName }
fun' = fun { funcDecl = funcDecl' }
funTy = LMFunction funcDecl'
View Lorry Controller Status