diff --git a/ghc/compiler/cmm/CLabel.hs b/ghc/compiler/cmm/CLabel.hs
index c0c6e34ac4617b4312598e5af6752b627fea9802..a2634daa123c2221ee82a894c8bb0baf8c91de22 100644
--- a/ghc/compiler/cmm/CLabel.hs
+++ b/ghc/compiler/cmm/CLabel.hs
@@ -74,9 +74,15 @@ module CLabel (
mkCCLabel, mkCCSLabel,
+ DynamicLinkerLabelInfo(..),
+ mkDynamicLinkerLabel,
+ dynamicLinkerLabelInfo,
+
+ mkPicBaseLabel,
+
infoLblToEntryLbl, entryLblToInfoLbl,
needsCDecl, isAsmTemp, externallyVisibleCLabel,
- CLabelType(..), labelType, labelDynamic, labelCouldBeDynamic,
+ CLabelType(..), labelType, labelDynamic,
pprCLabel
) where
@@ -97,7 +103,6 @@ import CostCentre ( CostCentre, CostCentreStack )
import Outputable
import FastString
-
-- -----------------------------------------------------------------------------
-- The CLabel type
@@ -163,9 +168,21 @@ data CLabel
| CC_Label CostCentre
| CCS_Label CostCentreStack
+ -- Dynamic Linking in the NCG:
+ -- generated and used inside the NCG only,
+ -- see module PositionIndependentCode for details.
+
+ | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel
+ -- special variants of a label used for dynamic linking
+
+ | PicBaseLabel -- a label used as a base for PIC calculations
+ -- on some platforms.
+ -- It takes the form of a local numeric
+ -- assembler label '1'; it is pretty-printed
+ -- as 1b, referring to the previous definition
+ -- of 1: in the assembler source file.
deriving (Eq, Ord)
-
data IdLabelInfo
= Closure -- Label for closure
| SRT -- Static reference table
@@ -226,6 +243,14 @@ data RtsLabelInfo
-- NOTE: Eq on LitString compares the pointer only, so this isn't
-- a real equality.
+data DynamicLinkerLabelInfo
+ = CodeStub -- MachO: Lfoo$stub, ELF: foo@plt
+ | SymbolPtr -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo
+ | GotSymbolPtr -- ELF: foo@got
+ | GotSymbolOffset -- ELF: foo@gotoff
+
+ deriving (Eq, Ord)
+
-- -----------------------------------------------------------------------------
-- Constructing CLabels
@@ -309,6 +334,20 @@ mkRtsDataLabelFS str = RtsLabel (RtsDataFS str)
mkRtsSlowTickyCtrLabel :: String -> CLabel
mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat)
+ -- Dynamic linking
+
+mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel
+mkDynamicLinkerLabel = DynamicLinkerLabel
+
+dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel)
+dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl)
+dynamicLinkerLabelInfo _ = Nothing
+
+ -- Position independent code
+
+mkPicBaseLabel :: CLabel
+mkPicBaseLabel = PicBaseLabel
+
-- -----------------------------------------------------------------------------
-- Converting info labels to entry labels.
@@ -345,8 +384,7 @@ needsCDecl (IdLabel _ SRT) = False
needsCDecl (IdLabel _ SRTDesc) = False
needsCDecl (IdLabel _ Bitmap) = False
needsCDecl (IdLabel _ _) = True
-needsCDecl (CaseLabel _ CaseReturnPt) = True
-needsCDecl (CaseLabel _ CaseReturnInfo) = True
+needsCDecl (CaseLabel _ _) = True
needsCDecl (ModuleInitLabel _ _) = True
needsCDecl (PlainModuleInitLabel _) = True
needsCDecl ModuleRegdLabel = False
@@ -384,7 +422,7 @@ externallyVisibleCLabel (ForeignLabel _ _ _) = True
externallyVisibleCLabel (IdLabel id _) = isExternalName id
externallyVisibleCLabel (CC_Label _) = True
externallyVisibleCLabel (CCS_Label _) = True
-
+externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
-- -----------------------------------------------------------------------------
-- Finding the "type" of a CLabel
@@ -411,7 +449,7 @@ labelType (RtsLabel (RtsEntryFS _)) = CodeLabel
labelType (RtsLabel (RtsRetInfoFS _)) = DataLabel
labelType (RtsLabel (RtsRetFS _)) = CodeLabel
labelType (CaseLabel _ CaseReturnInfo) = DataLabel
-labelType (CaseLabel _ CaseReturnPt) = CodeLabel
+labelType (CaseLabel _ _) = CodeLabel
labelType (ModuleInitLabel _ _) = CodeLabel
labelType (PlainModuleInitLabel _) = CodeLabel
@@ -441,23 +479,19 @@ labelDynamic lbl =
case lbl of
RtsLabel _ -> not opt_Static -- i.e., is the RTS in a DLL or not?
IdLabel n k -> isDllName n
+#if mingw32_TARGET_OS
ForeignLabel _ _ d -> d
+#else
+ -- On Mac OS X and on ELF platforms, false positives are OK,
+ -- so we claim that all foreign imports come from dynamic libraries
+ ForeignLabel _ _ _ -> True
+#endif
ModuleInitLabel m _ -> (not opt_Static) && (not (isHomeModule m))
PlainModuleInitLabel m -> (not opt_Static) && (not (isHomeModule m))
+
+ -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
_ -> False
--- Basically the same as above, but this time for Darwin only.
--- The things that GHC does when labelDynamic returns true are not quite right
--- for Darwin. Also, every ForeignLabel might possibly be from a dynamic library,
--- and a 'false positive' doesn't really hurt on Darwin, so this just returns
--- True for every ForeignLabel.
---
--- ToDo: Clean up DLL-related code so we can do away with the distinction
--- between this and labelDynamic above.
-
-labelCouldBeDynamic (ForeignLabel _ _ _) = True
-labelCouldBeDynamic lbl = labelDynamic lbl
-
{-
OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
right places. It is used to detect when the abstractC statement of an
@@ -514,6 +548,12 @@ pprCLabel (AsmTempLabel u)
ptext asmTempLabelPrefix <> pprUnique u
else
char '_' <> pprUnique u
+
+pprCLabel (DynamicLinkerLabel info lbl)
+ = pprDynamicLinkerAsmLabel info lbl
+
+pprCLabel PicBaseLabel
+ = ptext SLIT("1b")
#endif
pprCLabel lbl =
@@ -668,3 +708,29 @@ asmTempLabelPrefix =
#else
SLIT(".L")
#endif
+
+pprDynamicLinkerAsmLabel :: DynamicLinkerLabelInfo -> CLabel -> SDoc
+
+#if darwin_TARGET_OS
+pprDynamicLinkerAsmLabel SymbolPtr lbl
+ = char 'L' <> pprCLabel lbl <> text "$non_lazy_ptr"
+pprDynamicLinkerAsmLabel CodeStub lbl
+ = char 'L' <> pprCLabel lbl <> text "$stub"
+#elif powerpc_TARGET_ARCH && linux_TARGET_OS
+pprDynamicLinkerAsmLabel CodeStub lbl
+ = pprCLabel lbl <> text "@plt"
+pprDynamicLinkerAsmLabel SymbolPtr lbl
+ = text ".LC_" <> pprCLabel lbl
+#elif linux_TARGET_OS
+pprDynamicLinkerAsmLabel CodeStub lbl
+ = pprCLabel lbl <> text "@plt"
+pprDynamicLinkerAsmLabel GotSymbolPtr lbl
+ = pprCLabel lbl <> text "@got"
+pprDynamicLinkerAsmLabel GotSymbolOffset lbl
+ = pprCLabel lbl <> text "@gotoff"
+#elif mingw32_TARGET_OS
+pprDynamicLinkerAsmLabel SymbolPtr lbl
+ = text "__imp_" <> pprCLabel lbl
+#endif
+pprDynamicLinkerAsmLabel _ _
+ = panic "pprDynamicLinkerAsmLabel"
diff --git a/ghc/compiler/cmm/Cmm.hs b/ghc/compiler/cmm/Cmm.hs
index cf76f459a71b7804431aca77cb788eb3ea96b2a6..9fcc96ed01985c2258d7eccf4f6749ea26ece946 100644
--- a/ghc/compiler/cmm/Cmm.hs
+++ b/ghc/compiler/cmm/Cmm.hs
@@ -162,6 +162,7 @@ data CmmExpr
-- ** is shorthand only, meaning **
-- CmmMachOp (MO_S_Add rep (CmmReg reg) (CmmLit (CmmInt i rep)))
-- where rep = cmmRegRep reg
+ | CmmPicBaseReg -- Base Register for PIC calculations
cmmExprRep :: CmmExpr -> MachRep
cmmExprRep (CmmLit lit) = cmmLitRep lit
@@ -169,6 +170,7 @@ cmmExprRep (CmmLoad _ rep) = rep
cmmExprRep (CmmReg reg) = cmmRegRep reg
cmmExprRep (CmmMachOp op _) = resultRepOfMachOp op
cmmExprRep (CmmRegOff reg _) = cmmRegRep reg
+cmmExprRep CmmPicBaseReg = wordRep
data CmmReg
= CmmLocal LocalReg
@@ -201,12 +203,22 @@ data CmmLit
| CmmFloat Rational MachRep
| CmmLabel CLabel -- Address of label
| CmmLabelOff CLabel Int -- Address of label + byte offset
+
+ -- Due to limitations in the C backend, the following
+ -- MUST ONLY be used inside the info table indicated by label2
+ -- (label2 must be the info label), and label1 must be an
+ -- SRT, a slow entrypoint or a large bitmap (see the Mangler)
+ -- Don't use it at all unless tablesNextToCode.
+ -- It is also used inside the NCG during when generating
+ -- position-independent code.
+ | CmmLabelDiffOff CLabel CLabel Int -- label1 - label2 + offset
cmmLitRep :: CmmLit -> MachRep
cmmLitRep (CmmInt _ rep) = rep
cmmLitRep (CmmFloat _ rep) = rep
cmmLitRep (CmmLabel _) = wordRep
cmmLitRep (CmmLabelOff _ _) = wordRep
+cmmLitRep (CmmLabelDiffOff _ _ _) = wordRep
-----------------------------------------------------------------------------
-- A local label.
diff --git a/ghc/compiler/cmm/CmmParse.y b/ghc/compiler/cmm/CmmParse.y
index 55ee5c221982e8410e0e018a1214ca1ddd242889..7eb4bdbfde5bd18e24f75dd42f2245e26cc8ab22 100644
--- a/ghc/compiler/cmm/CmmParse.y
+++ b/ghc/compiler/cmm/CmmParse.y
@@ -464,7 +464,7 @@ exprMacros = listToUFM [
( FSLIT("INFO_TYPE"), \ [x] -> infoTableClosureType x ),
( FSLIT("INFO_PTRS"), \ [x] -> infoTablePtrs x ),
( FSLIT("INFO_NPTRS"), \ [x] -> infoTableNonPtrs x ),
- ( FSLIT("RET_VEC"), \ [info, conZ] -> CmmLoad (vectorSlot info conZ) wordRep )
+ ( FSLIT("RET_VEC"), \ [info, conZ] -> retVec info conZ )
]
-- we understand a subset of C-- primitives:
@@ -677,9 +677,10 @@ forkLabelledCodeEC ec = do
retInfo name size live_bits cl_type vector = do
let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits)
- (info1,info2) = mkRetInfoTable liveness NoC_SRT
+ info_lbl = mkRtsRetInfoLabelFS name
+ (info1,info2) = mkRetInfoTable info_lbl liveness NoC_SRT
(fromIntegral cl_type) vector
- return (mkRtsRetInfoLabelFS name, info1, info2)
+ return (info_lbl, info1, info2)
stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str =
basicInfo name (packHalfWordsCLit ptrs nptrs)
@@ -854,7 +855,9 @@ doSwitch mb_range scrut arms deflt
initEnv :: Env
initEnv = listToUFM [
( FSLIT("SIZEOF_StgHeader"),
- CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) )
+ CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) ),
+ ( FSLIT("SIZEOF_StgInfoTable"),
+ CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) )
]
parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm)
diff --git a/ghc/compiler/cmm/PprC.hs b/ghc/compiler/cmm/PprC.hs
index 630f6a5bb6cd3543ca77f4b191baff54925ea2e0..a9aba407deb2ff4ca590d9d617ebd2a299cc2c11 100644
--- a/ghc/compiler/cmm/PprC.hs
+++ b/ghc/compiler/cmm/PprC.hs
@@ -85,7 +85,8 @@ pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
pprTop :: CmmTop -> SDoc
pprTop (CmmProc info clbl _params blocks) =
(if not (null info)
- then pprWordArray (entryLblToInfoLbl clbl) info
+ then pprDataExterns info $$
+ pprWordArray (entryLblToInfoLbl clbl) info
else empty) $$
(case blocks of
[] -> empty
@@ -367,9 +368,18 @@ pprLit lit = case lit of
CmmFloat f rep -> parens (machRepCType rep) <> (rational f)
CmmLabel clbl -> mkW_ <> pprCLabel clbl
CmmLabelOff clbl i -> mkW_ <> pprCLabel clbl <> char '+' <> int i
+ CmmLabelDiffOff clbl1 clbl2 i
+ -- 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_ <> pprCLabel clbl1 <> char '+' <> int i
pprLit1 :: CmmLit -> SDoc
pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
+pprLit1 lit@(CmmLabelDiffOff _ _ _) = parens (pprLit lit)
pprLit1 lit@(CmmFloat _ _) = parens (pprLit lit)
pprLit1 other = pprLit other
@@ -786,6 +796,8 @@ te_BB (BasicBlock _ ss) = mapM_ te_Stmt ss
te_Lit :: CmmLit -> TE ()
te_Lit (CmmLabel l) = te_lbl l
+te_Lit (CmmLabelOff l _) = te_lbl l
+te_Lit (CmmLabelDiffOff l1 l2 _) = te_lbl l1
te_Lit _ = return ()
te_Stmt :: CmmStmt -> TE ()
diff --git a/ghc/compiler/cmm/PprCmm.hs b/ghc/compiler/cmm/PprCmm.hs
index 961c6e40e163401c8fc02870257afb7cece52216..38e7e06e54e934fb69b74d90d2679b0adf8a850a 100644
--- a/ghc/compiler/cmm/PprCmm.hs
+++ b/ghc/compiler/cmm/PprCmm.hs
@@ -369,6 +369,8 @@ pprLit lit = case lit of
CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
CmmLabel clbl -> pprCLabel clbl
CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
+ CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
+ <> pprCLabel clbl2 <> ppr_offset i
pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
pprLit1 lit = pprLit lit
diff --git a/ghc/compiler/codeGen/CgInfoTbls.hs b/ghc/compiler/codeGen/CgInfoTbls.hs
index 5cda82352aa9718a50387afe7325948364df3947..7692e7d71b1b9b11f060e5d2411078a446b3f72a 100644
--- a/ghc/compiler/codeGen/CgInfoTbls.hs
+++ b/ghc/compiler/codeGen/CgInfoTbls.hs
@@ -15,13 +15,14 @@ module CgInfoTbls (
emitDirectReturnInstr, emitVectoredReturnInstr,
mkRetInfoTable,
mkStdInfoTable,
+ stdInfoTableSizeB,
mkFunGenInfoExtraBits,
entryCode, closureInfoPtr,
getConstrTag,
infoTable, infoTableClosureType,
infoTablePtrs, infoTableNonPtrs,
funInfoTable,
- vectorSlot,
+ retVec
) where
@@ -120,7 +121,7 @@ emitClosureCodeAndInfoTable cl_info args body
(mkIntCLit 0, fromIntegral (dataConTagZ con))
Nothing -> -- Not a constructor
- srtLabelAndLength srt
+ srtLabelAndLength srt info_lbl
ptrs = closurePtrsSize cl_info
nptrs = size - ptrs
@@ -141,11 +142,14 @@ emitClosureCodeAndInfoTable cl_info args body
| ArgGen liveness <- arg_descr
= [ fun_amode,
srt_label,
- mkLivenessCLit liveness,
- CmmLabel (mkSlowEntryLabel (closureName cl_info)) ]
+ makeRelativeRefTo info_lbl $ mkLivenessCLit liveness,
+ slow_entry ]
| needs_srt = [fun_amode, srt_label]
| otherwise = [fun_amode]
+ slow_entry = makeRelativeRefTo info_lbl (CmmLabel slow_entry_label)
+ slow_entry_label = mkSlowEntryLabel (closureName cl_info)
+
fun_amode = packHalfWordsCLit fun_type arity
fun_type = argDescrType arg_descr
@@ -207,7 +211,15 @@ vectorSlot info_amode zero_indexed_tag
zero_indexed_tag
-- The "2" is one for the entry-code slot and one for the SRT slot
-
+retVec :: CmmExpr -> CmmExpr -> CmmExpr
+-- Get a return vector from the info pointer
+retVec info_amode zero_indexed_tag
+ = let slot = vectorSlot info_amode zero_indexed_tag
+ tableEntry = CmmLoad slot wordRep
+ in if tablesNextToCode
+ then CmmMachOp (MO_Add wordRep) [tableEntry, info_amode]
+ else tableEntry
+
emitReturnTarget
:: Name
-> CgStmts -- The direct-return code (if any)
@@ -229,7 +241,7 @@ emitReturnTarget name stmts vector srt
(False, False) -> rET_VEC_SMALL
(std_info, extra_bits) =
- mkRetInfoTable liveness srt_info cl_type vector
+ mkRetInfoTable info_lbl liveness srt_info cl_type vector
; blks <- cgStmtsToBlocks stmts
; emitInfoTableAndCode info_lbl std_info extra_bits args blks
@@ -241,15 +253,16 @@ emitReturnTarget name stmts vector srt
mkRetInfoTable
- :: Liveness -- liveness
+ :: CLabel -- info label
+ -> Liveness -- liveness
-> C_SRT -- SRT Info
-> Int -- type (eg. rET_SMALL)
-> [CmmLit] -- vector
-> ([CmmLit],[CmmLit])
-mkRetInfoTable liveness srt_info cl_type vector
+mkRetInfoTable info_lbl liveness srt_info cl_type vector
= (std_info, extra_bits)
where
- (srt_label, srt_len) = srtLabelAndLength srt_info
+ (srt_label, srt_len) = srtLabelAndLength srt_info info_lbl
srt_slot | need_srt = [srt_label]
| otherwise = []
@@ -259,9 +272,9 @@ mkRetInfoTable liveness srt_info cl_type vector
-- an SRT slot, so that the vector table is at a
-- known offset from the info pointer
- liveness_lit = mkLivenessCLit liveness
+ liveness_lit = makeRelativeRefTo info_lbl $ mkLivenessCLit liveness
std_info = mkStdInfoTable zeroCLit zeroCLit cl_type srt_len liveness_lit
- extra_bits = srt_slot ++ vector
+ extra_bits = srt_slot ++ map (makeRelativeRefTo info_lbl) vector
emitDirectReturnTarget
@@ -292,11 +305,15 @@ emitAlgReturnTarget name branches mb_deflt srt ret_conv
-- global labels, so we can't use them at the 'call site'
VectoredReturn fam_sz -> do
- { tagged_lbls <- mapFCs emit_alt branches
- ; deflt_lbl <- emit_deflt mb_deflt
+ { let tagged_lbls = zip (map fst branches) $
+ map (CmmLabel . mkAltLabel uniq . fst) branches
+ deflt_lbl | isJust mb_deflt = CmmLabel $ mkDefaultLabel uniq
+ | otherwise = mkIntCLit 0
; let vector = [ assocDefault deflt_lbl tagged_lbls i
| i <- [0..fam_sz-1]]
; lbl <- emitReturnTarget name noCgStmts vector srt
+ ; mapFCs emit_alt branches
+ ; emit_deflt mb_deflt
; return (lbl, Just (tagged_lbls, deflt_lbl)) }
where
uniq = getUnique name
@@ -331,9 +348,8 @@ emitVectoredReturnInstr :: CmmExpr -- *Zero-indexed* constructor tag
-> Code
emitVectoredReturnInstr zero_indexed_tag
= do { info_amode <- getSequelAmode
- ; let slot = vectorSlot info_amode zero_indexed_tag
- ; stmtC (CmmJump (CmmLoad slot wordRep) []) }
-
+ ; let target = retVec info_amode zero_indexed_tag
+ ; stmtC (CmmJump target []) }
-------------------------------------------------------------------------
@@ -532,7 +548,31 @@ getSRTInfo id (SRT off len bmp)
srt_escape = (-1) :: StgHalfWord
-srtLabelAndLength :: C_SRT -> (CmmLit, StgHalfWord)
-srtLabelAndLength NoC_SRT = (zeroCLit, 0)
-srtLabelAndLength (C_SRT lbl off bitmap) = (cmmLabelOffW lbl off, bitmap)
+srtLabelAndLength :: C_SRT -> CLabel -> (CmmLit, StgHalfWord)
+srtLabelAndLength NoC_SRT _
+ = (zeroCLit, 0)
+srtLabelAndLength (C_SRT lbl off bitmap) info_lbl
+ = (makeRelativeRefTo info_lbl $ cmmLabelOffW lbl off, bitmap)
+-------------------------------------------------------------------------
+--
+-- 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
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 64ed4adaf5d9170b37983b0f99bca6ff63f731b6..6042f15763fcbe28d2eef56b4bb25e2a5ce415b3 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -93,7 +93,8 @@ module CmdLineOpts (
opt_OmitBlackHoling,
opt_Static,
opt_Unregisterised,
- opt_EmitExternalCore
+ opt_EmitExternalCore,
+ opt_PIC
) where
#include "HsVersions.h"
@@ -832,6 +833,8 @@ opt_EmitExternalCore = lookUp FSLIT("-fext-core")
-- Include full span info in error messages, instead of just the start position.
opt_ErrorSpans = lookUp FSLIT("-ferror-spans")
+
+opt_PIC = lookUp FSLIT("-fPIC")
\end{code}
%************************************************************************
@@ -874,7 +877,8 @@ isStaticHscFlag f =
"frule-check",
"frules-off",
"fcpr-off",
- "ferror-spans"
+ "ferror-spans",
+ "fPIC"
]
|| any (flip prefixMatch f) [
"fcontext-stack",
diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs
index c09e43ad2dc31529c39564a5614b6eb5b44e6fe9..b3bda23701e98dffa40061fb10db04af7247d7e6 100644
--- a/ghc/compiler/main/DriverFlags.hs
+++ b/ghc/compiler/main/DriverFlags.hs
@@ -621,11 +621,20 @@ machdepCCOpts
-- for "normal" programs, but it doesn't support register variable
-- declarations.
-- -mdynamic-no-pic:
- -- As we don't support haskell code in shared libraries anyway,
- -- we might as well turn of PIC code generation and save space and time.
- -- This is completely optional.
- = return ( ["-no-cpp-precomp","-mdynamic-no-pic"], [] )
-
+ -- Turn off PIC code generation to save space and time.
+ -- -fno-common:
+ -- Don't generate "common" symbols - these are unwanted
+ -- in dynamic libraries.
+
+ = if opt_PIC
+ then return ( ["-no-cpp-precomp", "-fno-common"],
+ ["-fno-common"] )
+ else return ( ["-no-cpp-precomp", "-mdynamic-no-pic"],
+ ["-mdynamic-no-pic"] )
+
+ | prefixMatch "powerpc" cTARGETPLATFORM && opt_PIC
+ = return ( ["-fPIC"], ["-fPIC"] )
+
| otherwise
= return ( [], [] )
diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs
index 8f97d55e50ed26c84ff1ed22ce4abcefc625ca9c..7f0bd452c383c3bb9421a7f4a5980899d5cd2e58 100644
--- a/ghc/compiler/nativeGen/AsmCodeGen.lhs
+++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs
@@ -19,11 +19,12 @@ import PprMach
import RegisterAlloc
import RegAllocInfo ( jumpDests )
import NCGMonad
+import PositionIndependentCode
import Cmm
import PprCmm ( pprStmt, pprCmms )
import MachOp
-import CLabel ( CLabel, mkSplitMarkerLabel )
+import CLabel ( CLabel, mkSplitMarkerLabel, mkAsmTempLabel )
#if powerpc_TARGET_ARCH
import CLabel ( mkRtsCodeLabel )
#endif
@@ -32,13 +33,13 @@ import UniqFM
import Unique ( Unique, getUnique )
import UniqSupply
import FastTypes
-#if darwin_TARGET_OS
-import PprMach ( pprDyldSymbolStub )
-import List ( group, sort )
+#if darwin_TARGET_OS || (powerpc_TARGET_ARCH && linux_TARGET_OS)
+import List ( groupBy, sortBy )
+import CLabel ( pprCLabel )
#endif
import ErrUtils ( dumpIfSet_dyn )
import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_Static,
- opt_EnsureSplittableC )
+ opt_EnsureSplittableC, opt_PIC )
import Digraph
import qualified Pretty
@@ -112,21 +113,10 @@ The machine-dependent bits break down as follows:
nativeCodeGen :: DynFlags -> [Cmm] -> UniqSupply -> IO Pretty.Doc
nativeCodeGen dflags cmms us
- | not opt_Static
- = panic "NCG does not handle dynamic libraries right now"
- -- ToDo: MachCodeGen used to have derefDLL function which expanded
- -- dynamic CLabels (labelDynamic lbl == True) into the appropriate
- -- dereferences. This should be done in the pre-NCG cmmToCmm pass instead.
- -- It doesn't apply to static data, of course. There are hacks so that
- -- the RTS knows what to do for references to closures in a DLL in SRTs,
- -- and we never generate a reference to a closure in another DLL in a
- -- static constructor.
-
- | otherwise
= let ((ppr_cmms, insn_sdoc, imports), _) = initUs us $
cgCmm (concat (map add_split cmms))
- cgCmm :: [CmmTop] -> UniqSM (Cmm, Pretty.Doc, [(Bool, CLabel)])
+ cgCmm :: [CmmTop] -> UniqSM (Cmm, Pretty.Doc, [CLabel])
cgCmm tops =
lazyMapUs (cmmNativeGen dflags) tops `thenUs` \ results ->
let (cmms,docs,imps) = unzip3 results in
@@ -143,11 +133,28 @@ nativeCodeGen dflags cmms us
split_marker = CmmProc [] mkSplitMarkerLabel [] []
-#if darwin_TARGET_OS
+#if darwin_TARGET_OS || (powerpc_TARGET_ARCH && linux_TARGET_OS)
-- Generate "symbol stubs" for all external symbols that might
-- come from a dynamic library.
- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
- map head $ group $ sort imps
+{- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
+ map head $ group $ sort imps-}
+
+ -- (Hack) sometimes two Labels pretty-print the same, but have
+ -- different uniques; so we compare their text versions...
+ dyld_stubs imps
+ | needImportedSymbols
+ = Pretty.vcat $
+ (pprGotDeclaration :) $
+ map (pprImportedSymbol . fst . head) $
+ groupBy (\(_,a) (_,b) -> a == b) $
+ sortBy (\(_,a) (_,b) -> compare a b) $
+ map doPpr $
+ imps
+ | otherwise
+ = Pretty.empty
+
+ where doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
+ astyle = mkCodeStyle AsmStyle
#else
dyld_stubs imps = Pretty.empty
#endif
@@ -169,17 +176,17 @@ nativeCodeGen dflags cmms us
-- Complete native code generation phase for a single top-level chunk
-- of Cmm.
-cmmNativeGen :: DynFlags -> CmmTop -> UniqSM (CmmTop, Pretty.Doc, [(Bool,CLabel)])
+cmmNativeGen :: DynFlags -> CmmTop -> UniqSM (CmmTop, Pretty.Doc, [CLabel])
cmmNativeGen dflags cmm
= {-# SCC "fixAssigns" #-}
fixAssignsTop cmm `thenUs` \ fixed_cmm ->
{-# SCC "genericOpt" #-}
- cmmToCmm fixed_cmm `bind` \ cmm ->
+ cmmToCmm fixed_cmm `bind` \ (cmm, imports) ->
(if dopt Opt_D_dump_opt_cmm dflags -- space leak avoidance
then cmm
else CmmData Text []) `bind` \ ppr_cmm ->
{-# SCC "genMachCode" #-}
- genMachCode cmm `thenUs` \ (pre_regalloc, imports) ->
+ genMachCode cmm `thenUs` \ (pre_regalloc, lastMinuteImports) ->
{-# SCC "regAlloc" #-}
map regAlloc pre_regalloc `bind` \ with_regs ->
{-# SCC "sequenceBlocks" #-}
@@ -189,7 +196,7 @@ cmmNativeGen dflags cmm
{-# SCC "vcat" #-}
Pretty.vcat (map pprNatCmmTop final_mach_code) `bind` \ final_sdoc ->
- returnUs (ppr_cmm, final_sdoc Pretty.$$ Pretty.text "", imports)
+ returnUs (ppr_cmm, final_sdoc Pretty.$$ Pretty.text "", lastMinuteImports ++ imports)
where
x86fp_kludge :: NatCmmTop -> NatCmmTop
x86fp_kludge top@(CmmData _ _) = top
@@ -279,7 +286,7 @@ reorder id accum (b@(block,id',out) : rest)
-- Switching between the two monads whilst carrying along the same
-- Unique supply breaks abstraction. Is that bad?
-genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [(Bool,CLabel)])
+genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [CLabel])
genMachCode cmm_top initial_us
= let initial_st = mkNatM_State initial_us 0
@@ -323,7 +330,7 @@ fixAssign (CmmAssign (CmmGlobal BaseReg) src)
fixAssign (CmmAssign (CmmGlobal reg) src)
| Left realreg <- reg_or_addr
- = returnUs [CmmAssign (CmmGlobal reg) (cmmExprConFold src)]
+ = returnUs [CmmAssign (CmmGlobal reg) src]
| Right baseRegAddr <- reg_or_addr
= returnUs [CmmStore baseRegAddr src]
-- Replace register leaves with appropriate StixTrees for
@@ -362,6 +369,10 @@ Here we do:
(c) Replacement of references to GlobalRegs which do not have
machine registers by the appropriate memory load (eg.
Hp ==> *(BaseReg + 34) ).
+ (d) Position independent code and dynamic linking
+ (i) introduce the appropriate indirections
+ and position independent refs
+ (ii) compile a list of imported symbols
Ideas for other things we could do (ToDo):
@@ -369,73 +380,114 @@ Ideas for other things we could do (ToDo):
- eliminate dead code blocks
-}
-cmmToCmm :: CmmTop -> CmmTop
-cmmToCmm top@(CmmData _ _) = top
-cmmToCmm (CmmProc info lbl params blocks) =
- CmmProc info lbl params (map cmmBlockConFold (cmmPeep blocks))
+cmmToCmm :: CmmTop -> (CmmTop, [CLabel])
+cmmToCmm top@(CmmData _ _) = (top, [])
+cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do
+ blocks' <- mapM cmmBlockConFold (cmmPeep blocks)
+ return $ CmmProc info lbl params blocks'
-cmmBlockConFold :: CmmBasicBlock -> CmmBasicBlock
-cmmBlockConFold (BasicBlock id stmts) =
- BasicBlock id (map cmmStmtConFold stmts)
+newtype CmmOptM a = CmmOptM ([CLabel] -> (# a, [CLabel] #))
+
+instance Monad CmmOptM where
+ return x = CmmOptM $ \imports -> (# x,imports #)
+ (CmmOptM f) >>= g =
+ CmmOptM $ \imports ->
+ case f imports of
+ (# x, imports' #) ->
+ case g x of
+ CmmOptM g' -> g' imports'
+
+addImportCmmOpt :: CLabel -> CmmOptM ()
+addImportCmmOpt lbl = CmmOptM $ \imports -> (# (), lbl:imports #)
+
+runCmmOpt :: CmmOptM a -> (a, [CLabel])
+runCmmOpt (CmmOptM f) = case f [] of
+ (# result, imports #) -> (result, imports)
+
+cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
+cmmBlockConFold (BasicBlock id stmts) = do
+ stmts' <- mapM cmmStmtConFold stmts
+ return $ BasicBlock id stmts'
cmmStmtConFold stmt
= case stmt of
CmmAssign reg src
- -> case cmmExprConFold src of
- CmmReg reg' | reg == reg' -> CmmNop
- new_src -> CmmAssign reg new_src
+ -> do src' <- cmmExprConFold False src
+ return $ case src' of
+ CmmReg reg' | reg == reg' -> CmmNop
+ new_src -> CmmAssign reg new_src
CmmStore addr src
- -> CmmStore (cmmExprConFold addr) (cmmExprConFold src)
+ -> do addr' <- cmmExprConFold False addr
+ src' <- cmmExprConFold False src
+ return $ CmmStore addr' src'
CmmJump addr regs
- -> CmmJump (cmmExprConFold addr) regs
+ -> do addr' <- cmmExprConFold True addr
+ return $ CmmJump addr' regs
CmmCall target regs args vols
- -> CmmCall (case target of
- CmmForeignCall e conv ->
- CmmForeignCall (cmmExprConFold e) conv
- other -> other)
- regs
- [ (cmmExprConFold arg,hint) | (arg,hint) <- args ]
- vols
+ -> do target' <- case target of
+ CmmForeignCall e conv -> do
+ e' <- cmmExprConFold True e
+ return $ CmmForeignCall e' conv
+ other -> return other
+ args' <- mapM (\(arg, hint) -> do
+ arg' <- cmmExprConFold False arg
+ return (arg', hint)) args
+ return $ CmmCall target' regs args' vols
CmmCondBranch test dest
- -> let test_opt = cmmExprConFold test
- in
- case test_opt of
- CmmLit (CmmInt 0 _) ->
- CmmComment (mkFastString ("deleted: " ++
+ -> do test' <- cmmExprConFold False test
+ return $ case test' of
+ CmmLit (CmmInt 0 _) ->
+ CmmComment (mkFastString ("deleted: " ++
showSDoc (pprStmt stmt)))
- CmmLit (CmmInt n _) -> CmmBranch dest
- other -> CmmCondBranch (cmmExprConFold test) dest
+ CmmLit (CmmInt n _) -> CmmBranch dest
+ other -> CmmCondBranch test' dest
CmmSwitch expr ids
- -> CmmSwitch (cmmExprConFold expr) ids
+ -> do expr' <- cmmExprConFold False expr
+ return $ CmmSwitch expr' ids
other
- -> other
+ -> return other
-cmmExprConFold expr
+cmmExprConFold isJumpTarget expr
= case expr of
CmmLoad addr rep
- -> CmmLoad (cmmExprConFold addr) rep
+ -> do addr' <- cmmExprConFold False addr
+ return $ CmmLoad addr' rep
CmmMachOp mop args
-- For MachOps, we first optimize the children, and then we try
-- our hand at some constant-folding.
- -> cmmMachOpFold mop (map cmmExprConFold args)
+ -> do args' <- mapM (cmmExprConFold False) args
+ return $ cmmMachOpFold mop args'
+
+ CmmLit (CmmLabel lbl)
+ -> cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl
+ CmmLit (CmmLabelOff lbl off)
+ -> do dynRef <- cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl
+ return $ cmmMachOpFold (MO_Add wordRep) [
+ dynRef,
+ (CmmLit $ CmmInt (fromIntegral off) wordRep)
+ ]
#if powerpc_TARGET_ARCH
- -- On powerpc, it's easier to jump directly to a label than
+ -- On powerpc (non-PIC), it's easier to jump directly to a label than
-- to use the register table, so we replace these registers
-- with the corresponding labels:
CmmReg (CmmGlobal GCEnter1)
- -> CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1")))
+ | not opt_PIC
+ -> cmmExprConFold isJumpTarget $
+ CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
- -> CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
+ | not opt_PIC
+ -> cmmExprConFold isJumpTarget $
+ CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
#endif
CmmReg (CmmGlobal mid)
@@ -446,29 +498,29 @@ cmmExprConFold expr
-- and for all others we generate an indirection to its
-- location in the register table.
-> case get_GlobalReg_reg_or_addr mid of
- Left realreg -> expr
+ Left realreg -> return expr
Right baseRegAddr
-> case mid of
- BaseReg -> cmmExprConFold baseRegAddr
- other -> cmmExprConFold (CmmLoad baseRegAddr
+ BaseReg -> cmmExprConFold False baseRegAddr
+ other -> cmmExprConFold False (CmmLoad baseRegAddr
(globalRegRep mid))
-- eliminate zero offsets
CmmRegOff reg 0
- -> cmmExprConFold (CmmReg reg)
+ -> cmmExprConFold False (CmmReg reg)
CmmRegOff (CmmGlobal mid) offset
-- RegOf leaves are just a shorthand form. If the reg maps
-- to a real reg, we keep the shorthand, otherwise, we just
-- expand it and defer to the above code.
-> case get_GlobalReg_reg_or_addr mid of
- Left realreg -> expr
+ Left realreg -> return expr
Right baseRegAddr
- -> cmmExprConFold (CmmMachOp (MO_Add wordRep) [
+ -> cmmExprConFold False (CmmMachOp (MO_Add wordRep) [
CmmReg (CmmGlobal mid),
CmmLit (CmmInt (fromIntegral offset)
wordRep)])
other
- -> other
+ -> return other
-- -----------------------------------------------------------------------------
@@ -656,7 +708,6 @@ cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt n _))]
cmmMachOpFold mop args = CmmMachOp mop args
-
-- -----------------------------------------------------------------------------
-- exactLog2
diff --git a/ghc/compiler/nativeGen/MachCodeGen.hs b/ghc/compiler/nativeGen/MachCodeGen.hs
index 92855181d3f24d113b9c7317e1d88399e28e0cb8..22bd60df870023d0f65908531bc2213d8bce682e 100644
--- a/ghc/compiler/nativeGen/MachCodeGen.hs
+++ b/ghc/compiler/nativeGen/MachCodeGen.hs
@@ -20,6 +20,7 @@ module MachCodeGen ( cmmTopCodeGen, InstrBlock ) where
import MachInstrs
import MachRegs
import NCGMonad
+import PositionIndependentCode ( cmmMakeDynamicReference, initializePicBase )
-- Our intermediate code:
import PprCmm ( pprExpr )
@@ -28,7 +29,7 @@ import MachOp
import CLabel
-- The rest:
-import CmdLineOpts ( opt_Static )
+import CmdLineOpts ( opt_PIC )
import ForeignCall ( CCallConv(..) )
import OrdList
import Pretty
@@ -60,7 +61,13 @@ type InstrBlock = OrdList Instr
cmmTopCodeGen :: CmmTop -> NatM [NatCmmTop]
cmmTopCodeGen (CmmProc info lab params blocks) = do
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
- return (CmmProc info lab params (concat nat_blocks) : concat statics)
+ picBaseMb <- getPicBaseMaybeNat
+ let proc = CmmProc info lab params (concat nat_blocks)
+ tops = proc : concat statics
+ case picBaseMb of
+ Just picBase -> initializePicBase picBase tops
+ Nothing -> return tops
+
cmmTopCodeGen (CmmData sec dat) = do
return [CmmData sec dat] -- no translation, we just use CmmStatic
@@ -488,6 +495,11 @@ getRegister (CmmReg reg)
getRegister tree@(CmmRegOff _ _)
= getRegister (mangleIndexTree tree)
+getRegister CmmPicBaseReg
+ = do
+ reg <- getPicBaseNat wordRep
+ return (Fixed wordRep reg nilOL)
+
-- end of machine-"independent" bit; here we go on the rest...
#if alpha_TARGET_ARCH
@@ -1461,6 +1473,23 @@ getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps
MO_Mul F64 -> trivialCodeNoImm F64 (FMUL F64) x y
MO_S_Quot F64 -> trivialCodeNoImm F64 (FDIV F64) x y
+ -- optimize addition with 32-bit immediate
+ -- (needed for PIC)
+ MO_Add I32 ->
+ case y of
+ CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate I32 True (-imm)
+ -> trivialCode I32 True ADD x (CmmLit $ CmmInt imm immrep)
+ CmmLit lit
+ -> do
+ (src, srcCode) <- getSomeReg x
+ let imm = litToImm lit
+ code dst = srcCode `appOL` toOL [
+ ADDIS dst src (HA imm),
+ ADD dst dst (RIImm (LO imm))
+ ]
+ return (Any I32 code)
+ _ -> trivialCode I32 True ADD x y
+
MO_Add rep -> trivialCode rep True ADD x y
MO_Sub rep ->
case y of -- subfi ('substract from' with immediate) doesn't exist
@@ -1496,53 +1525,25 @@ getRegister (CmmLit (CmmInt i rep))
in
return (Any rep code)
-getRegister (CmmLit (CmmFloat f F32)) = do
- lbl <- getNewLabelNat
- tmp <- getNewRegNat I32
- let code dst = toOL [
- LDATA ReadOnlyData [CmmDataLabel lbl,
- CmmStaticLit (CmmFloat f F32)],
- LIS tmp (HA (ImmCLbl lbl)),
- LD F32 dst (AddrRegImm tmp (LO (ImmCLbl lbl)))
- ]
- -- in
- return (Any F32 code)
-
-getRegister (CmmLit (CmmFloat d F64)) = do
+getRegister (CmmLit (CmmFloat f frep)) = do
lbl <- getNewLabelNat
- tmp <- getNewRegNat I32
- let code dst = toOL [
+ dynRef <- cmmMakeDynamicReference addImportNat False lbl
+ Amode addr addr_code <- getAmode dynRef
+ let code dst =
LDATA ReadOnlyData [CmmDataLabel lbl,
- CmmStaticLit (CmmFloat d F64)],
- LIS tmp (HA (ImmCLbl lbl)),
- LD F64 dst (AddrRegImm tmp (LO (ImmCLbl lbl)))
- ]
- -- in
- return (Any F32 code)
-
-#if darwin_TARGET_OS
-getRegister (CmmLit (CmmLabel lbl))
- | labelCouldBeDynamic lbl
- = do
- addImportNat False lbl
- let imm = ImmDyldNonLazyPtr lbl
- code dst = toOL [
- LIS dst (HA imm),
- LD I32 dst (AddrRegImm dst (LO imm))
- ]
- return (Any I32 code)
-#endif
+ CmmStaticLit (CmmFloat f frep)]
+ `consOL` (addr_code `snocOL` LD frep dst addr)
+ return (Any frep code)
getRegister (CmmLit lit)
- = let
- rep = cmmLitRep lit
- imm = litToImm lit
- code dst = toOL [
- LIS dst (HI imm),
- OR dst dst (RIImm (LO imm))
- ]
- in
- return (Any rep code)
+ = let rep = cmmLitRep lit
+ imm = litToImm lit
+ code dst = toOL [
+ LIS dst (HI imm),
+ OR dst dst (RIImm (LO imm))
+ ]
+ in return (Any rep code)
+
getRegister other = pprPanic "getRegister(ppc)" (pprExpr other)
-- extend?Rep: wrap integer expression of type rep
@@ -1760,14 +1761,22 @@ getAmode (CmmMachOp (MO_Add I32) [x, CmmLit (CmmInt i _)])
(reg, code) <- getSomeReg x
return (Amode (AddrRegImm reg off) code)
+ -- optimize addition with 32-bit immediate
+ -- (needed for PIC)
+getAmode (CmmMachOp (MO_Add I32) [x, CmmLit lit])
+ = do
+ tmp <- getNewRegNat I32
+ (src, srcCode) <- getSomeReg x
+ let imm = litToImm lit
+ code = srcCode `snocOL` ADDIS tmp src (HA imm)
+ return (Amode (AddrRegImm tmp (LO imm)) code)
+
getAmode (CmmLit lit)
= do
tmp <- getNewRegNat I32
- let
+ let imm = litToImm lit
code = unitOL (LIS tmp (HA imm))
return (Amode (AddrRegImm tmp (LO imm)) code)
- where
- imm = litToImm lit
getAmode (CmmMachOp (MO_Add I32) [x, y])
= do
@@ -3142,12 +3151,16 @@ genCCall target dest_regs argsAndHints vols
initialStackOffset
(toOL []) []
+ (labelOrExpr, reduceToF32) <- case target of
+ CmmForeignCall (CmmLit (CmmLabel lbl)) conv -> return (Left lbl, False)
+ CmmForeignCall expr conv -> return (Right expr, False)
+ CmmPrim mop -> outOfLineFloatOp mop
+
let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode
- codeAfter = move_sp_up finalStack `appOL` moveResult
+ codeAfter = move_sp_up finalStack `appOL` moveResult reduceToF32
case labelOrExpr of
Left lbl -> do
- addImportNat True lbl
return ( codeBefore
`snocOL` BL lbl usedRegs
`appOL` codeAfter)
@@ -3270,7 +3283,7 @@ genCCall target dest_regs argsAndHints vols
F64 -> (0, 1, 8, fprs)
#endif
- moveResult =
+ moveResult reduceToF32 =
case dest_regs of
[] -> nilOL
[(dest, _hint)]
@@ -3282,47 +3295,51 @@ genCCall target dest_regs argsAndHints vols
where rep = cmmRegRep dest
r_dest = getRegisterReg dest
- (labelOrExpr, reduceToF32) = case target of
- CmmForeignCall (CmmLit (CmmLabel lbl)) conv -> (Left lbl, False)
- CmmForeignCall expr conv -> (Right expr, False)
- CmmPrim mop -> (Left $ mkForeignLabel label Nothing False, reduce)
- where
- (label, reduce) = case mop of
- MO_F32_Exp -> (FSLIT("exp"), True)
- MO_F32_Log -> (FSLIT("log"), True)
- MO_F32_Sqrt -> (FSLIT("sqrt"), True)
-
- MO_F32_Sin -> (FSLIT("sin"), True)
- MO_F32_Cos -> (FSLIT("cos"), True)
- MO_F32_Tan -> (FSLIT("tan"), True)
-
- MO_F32_Asin -> (FSLIT("asin"), True)
- MO_F32_Acos -> (FSLIT("acos"), True)
- MO_F32_Atan -> (FSLIT("atan"), True)
-
- MO_F32_Sinh -> (FSLIT("sinh"), True)
- MO_F32_Cosh -> (FSLIT("cosh"), True)
- MO_F32_Tanh -> (FSLIT("tanh"), True)
- MO_F32_Pwr -> (FSLIT("pow"), True)
-
- MO_F64_Exp -> (FSLIT("exp"), False)
- MO_F64_Log -> (FSLIT("log"), False)
- MO_F64_Sqrt -> (FSLIT("sqrt"), False)
+ outOfLineFloatOp mop =
+ do
+ mopExpr <- cmmMakeDynamicReference addImportNat True $
+ mkForeignLabel functionName Nothing True
+ let mopLabelOrExpr = case mopExpr of
+ CmmLit (CmmLabel lbl) -> Left lbl
+ _ -> Right mopExpr
+ return (mopLabelOrExpr, reduce)
+ where
+ (functionName, reduce) = case mop of
+ MO_F32_Exp -> (FSLIT("exp"), True)
+ MO_F32_Log -> (FSLIT("log"), True)
+ MO_F32_Sqrt -> (FSLIT("sqrt"), True)
- MO_F64_Sin -> (FSLIT("sin"), False)
- MO_F64_Cos -> (FSLIT("cos"), False)
- MO_F64_Tan -> (FSLIT("tan"), False)
+ MO_F32_Sin -> (FSLIT("sin"), True)
+ MO_F32_Cos -> (FSLIT("cos"), True)
+ MO_F32_Tan -> (FSLIT("tan"), True)
+
+ MO_F32_Asin -> (FSLIT("asin"), True)
+ MO_F32_Acos -> (FSLIT("acos"), True)
+ MO_F32_Atan -> (FSLIT("atan"), True)
+
+ MO_F32_Sinh -> (FSLIT("sinh"), True)
+ MO_F32_Cosh -> (FSLIT("cosh"), True)
+ MO_F32_Tanh -> (FSLIT("tanh"), True)
+ MO_F32_Pwr -> (FSLIT("pow"), True)
- MO_F64_Asin -> (FSLIT("asin"), False)
- MO_F64_Acos -> (FSLIT("acos"), False)
- MO_F64_Atan -> (FSLIT("atan"), False)
+ MO_F64_Exp -> (FSLIT("exp"), False)
+ MO_F64_Log -> (FSLIT("log"), False)
+ MO_F64_Sqrt -> (FSLIT("sqrt"), False)
- MO_F64_Sinh -> (FSLIT("sinh"), False)
- MO_F64_Cosh -> (FSLIT("cosh"), False)
- MO_F64_Tanh -> (FSLIT("tanh"), False)
- MO_F64_Pwr -> (FSLIT("pow"), False)
- other -> pprPanic "genCCall(ppc): unknown callish op"
- (pprCallishMachOp other)
+ MO_F64_Sin -> (FSLIT("sin"), False)
+ MO_F64_Cos -> (FSLIT("cos"), False)
+ MO_F64_Tan -> (FSLIT("tan"), False)
+
+ MO_F64_Asin -> (FSLIT("asin"), False)
+ MO_F64_Acos -> (FSLIT("acos"), False)
+ MO_F64_Atan -> (FSLIT("atan"), False)
+
+ MO_F64_Sinh -> (FSLIT("sinh"), False)
+ MO_F64_Cosh -> (FSLIT("cosh"), False)
+ MO_F64_Tanh -> (FSLIT("tanh"), False)
+ MO_F64_Pwr -> (FSLIT("pow"), False)
+ other -> pprPanic "genCCall(ppc): unknown callish op"
+ (pprCallishMachOp other)
#endif /* darwin_TARGET_OS || linux_TARGET_OS */
@@ -3348,23 +3365,42 @@ genSwitch expr ids = do
-- in
return code
#elif powerpc_TARGET_ARCH
-genSwitch expr ids = do
- (reg,e_code) <- getSomeReg expr
- tmp <- getNewRegNat I32
- lbl <- getNewLabelNat
- let
- jumpTable = map jumpTableEntry ids
-
- code = e_code `appOL` toOL [
- LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
- SLW tmp reg (RIImm (ImmInt 2)),
- ADDIS tmp tmp (HA (ImmCLbl lbl)),
- LD I32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
- MTCTR tmp,
- BCTR [ id | Just id <- ids ]
- ]
- -- in
- return code
+genSwitch expr ids
+ | opt_PIC
+ = do
+ (reg,e_code) <- getSomeReg expr
+ tmp <- getNewRegNat I32
+ lbl <- getNewLabelNat
+ dynRef <- cmmMakeDynamicReference addImportNat False lbl
+ (tableReg,t_code) <- getSomeReg $ dynRef
+ let
+ jumpTable = map jumpTableEntry ids
+
+ code = e_code `appOL` t_code `appOL` toOL [
+ LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+ SLW tmp reg (RIImm (ImmInt 2)),
+ LD I32 tmp (AddrRegReg tableReg tmp),
+ MTCTR tmp,
+ BCTR [ id | Just id <- ids ]
+ ]
+ return code
+ | otherwise
+ = do
+ (reg,e_code) <- getSomeReg expr
+ tmp <- getNewRegNat I32
+ lbl <- getNewLabelNat
+ let
+ jumpTable = map jumpTableEntry ids
+
+ code = e_code `appOL` toOL [
+ LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+ SLW tmp reg (RIImm (ImmInt 2)),
+ ADDIS tmp tmp (HA (ImmCLbl lbl)),
+ LD I32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
+ MTCTR tmp,
+ BCTR [ id | Just id <- ids ]
+ ]
+ return code
#else
genSwitch expr ids = panic "ToDo: genSwitch"
#endif
@@ -4147,6 +4183,8 @@ coerceInt2FP fromRep toRep x = do
lbl <- getNewLabelNat
itmp <- getNewRegNat I32
ftmp <- getNewRegNat F64
+ dynRef <- cmmMakeDynamicReference addImportNat False lbl
+ Amode addr addr_code <- getAmode dynRef
let
code' dst = code `appOL` maybe_exts `appOL` toOL [
LDATA ReadOnlyData
@@ -4157,9 +4195,9 @@ coerceInt2FP fromRep toRep x = do
ST I32 itmp (spRel 3),
LIS itmp (ImmInt 0x4330),
ST I32 itmp (spRel 2),
- LD F64 ftmp (spRel 2),
- LIS itmp (HA (ImmCLbl lbl)),
- LD F64 dst (AddrRegImm itmp (LO (ImmCLbl lbl))),
+ LD F64 ftmp (spRel 2)
+ ] `appOL` addr_code `appOL` toOL [
+ LD F64 dst addr,
FSUB F64 dst ftmp dst
] `appOL` maybe_frsp dst
@@ -4201,3 +4239,4 @@ eXTRA_STK_ARGS_HERE :: Int
eXTRA_STK_ARGS_HERE
= IF_ARCH_alpha(0, IF_ARCH_sparc(23, ???))
#endif
+
diff --git a/ghc/compiler/nativeGen/MachInstrs.hs b/ghc/compiler/nativeGen/MachInstrs.hs
index b0b68e4df5119a48c97fedd8344f2aa2e50e5d8c..4cfcc178bf71cee62b79349b86527c6870ad6628 100644
--- a/ghc/compiler/nativeGen/MachInstrs.hs
+++ b/ghc/compiler/nativeGen/MachInstrs.hs
@@ -661,6 +661,10 @@ fPair other = pprPanic "fPair(sparc NCG)" (ppr other)
| CRNOR Int Int Int -- condition register nor
| MFCR Reg -- move from condition register
+ | MFLR Reg -- move from link register
+ | FETCHPC Reg -- pseudo-instruction:
+ -- bcl to next insn, mflr reg
+
condUnsigned GU = True
condUnsigned LU = True
condUnsigned GEU = True
diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs
index e94086db494693a03ef6c71403ad9e424b3c340b..ec28f70075d3cec0e2c1176682d407b75190b475 100644
--- a/ghc/compiler/nativeGen/MachRegs.lhs
+++ b/ghc/compiler/nativeGen/MachRegs.lhs
@@ -107,6 +107,8 @@ data Imm
| ImmIndex CLabel Int
| ImmFloat Rational
| ImmDouble Rational
+ | ImmConstantSum Imm Imm
+ | ImmConstantDiff Imm Imm
#if sparc_TARGET_ARCH
| LO Imm {- Possible restrictions... -}
| HI Imm
@@ -115,10 +117,6 @@ data Imm
| LO Imm
| HI Imm
| HA Imm {- high halfword adjusted -}
-#if darwin_TARGET_OS
- -- special dyld (dynamic linker) things
- | ImmDyldNonLazyPtr CLabel -- Llabel$non_lazy_ptr
-#endif
#endif
strImmLit s = ImmLit (text s)
@@ -128,6 +126,10 @@ litToImm (CmmFloat f F32) = ImmFloat f
litToImm (CmmFloat f F64) = ImmDouble f
litToImm (CmmLabel l) = ImmCLbl l
litToImm (CmmLabelOff l off) = ImmIndex l off
+litToImm (CmmLabelDiffOff l1 l2 off)
+ = ImmConstantSum
+ (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
+ (ImmInt off)
-- -----------------------------------------------------------------------------
-- Addressing modes
diff --git a/ghc/compiler/nativeGen/NCGMonad.hs b/ghc/compiler/nativeGen/NCGMonad.hs
index 271828f5dea2bf3d8f279a494f2309255ce3b2a0..8fdcd44024fb99e462319f58a41e46155996511d 100644
--- a/ghc/compiler/nativeGen/NCGMonad.hs
+++ b/ghc/compiler/nativeGen/NCGMonad.hs
@@ -13,6 +13,7 @@ module NCGMonad (
initNat, addImportNat, getUniqueNat,
mapAccumLNat, setDeltaNat, getDeltaNat,
getBlockIdNat, getNewLabelNat, getNewRegNat, getNewRegPairNat,
+ getPicBaseMaybeNat, getPicBaseNat
) where
#include "HsVersions.h"
@@ -28,7 +29,8 @@ import Unique ( Unique )
data NatM_State = NatM_State {
natm_us :: UniqSupply,
natm_delta :: Int,
- natm_imports :: [(Bool,CLabel)]
+ natm_imports :: [(CLabel)],
+ natm_pic :: Maybe Reg
}
newtype NatM result = NatM (NatM_State -> (result, NatM_State))
@@ -36,7 +38,7 @@ newtype NatM result = NatM (NatM_State -> (result, NatM_State))
unNat (NatM a) = a
mkNatM_State :: UniqSupply -> Int -> NatM_State
-mkNatM_State us delta = NatM_State us delta []
+mkNatM_State us delta = NatM_State us delta [] Nothing
initNat :: NatM_State -> NatM a -> (a, NatM_State)
initNat init_st m = case unNat m init_st of { (r,st) -> (r,st) }
@@ -66,20 +68,20 @@ mapAccumLNat f b (x:xs)
return (b__3, x__2:xs__2)
getUniqueNat :: NatM Unique
-getUniqueNat = NatM $ \ (NatM_State us delta imports) ->
+getUniqueNat = NatM $ \ (NatM_State us delta imports pic) ->
case splitUniqSupply us of
- (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta imports))
+ (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta imports pic))
getDeltaNat :: NatM Int
getDeltaNat = NatM $ \ st -> (natm_delta st, st)
setDeltaNat :: Int -> NatM ()
-setDeltaNat delta = NatM $ \ (NatM_State us _ imports) ->
- ((), NatM_State us delta imports)
+setDeltaNat delta = NatM $ \ (NatM_State us _ imports pic) ->
+ ((), NatM_State us delta imports pic)
-addImportNat :: Bool -> CLabel -> NatM ()
-addImportNat is_code imp = NatM $ \ (NatM_State us delta imports) ->
- ((), NatM_State us delta ((is_code,imp):imports))
+addImportNat :: CLabel -> NatM ()
+addImportNat imp = NatM $ \ (NatM_State us delta imports pic) ->
+ ((), NatM_State us delta (imp:imports) pic)
getBlockIdNat :: NatM BlockId
getBlockIdNat = do u <- getUniqueNat; return (BlockId u)
@@ -96,3 +98,14 @@ getNewRegPairNat rep = do
let lo = mkVReg u rep; hi = getHiVRegFromLo lo
return (lo,hi)
+getPicBaseMaybeNat :: NatM (Maybe Reg)
+getPicBaseMaybeNat = NatM (\state -> (natm_pic state, state))
+
+getPicBaseNat :: MachRep -> NatM Reg
+getPicBaseNat rep = do
+ mbPicBase <- getPicBaseMaybeNat
+ case mbPicBase of
+ Just picBase -> return picBase
+ Nothing -> do
+ reg <- getNewRegNat rep
+ NatM (\state -> (reg, state { natm_pic = Just reg }))
diff --git a/ghc/compiler/nativeGen/PositionIndependentCode.hs b/ghc/compiler/nativeGen/PositionIndependentCode.hs
new file mode 100644
index 0000000000000000000000000000000000000000..d6812b13e3ce82394b2167951c877d0ad3fcf0a0
--- /dev/null
+++ b/ghc/compiler/nativeGen/PositionIndependentCode.hs
@@ -0,0 +1,475 @@
+#include "../includes/ghcconfig.h"
+
+module PositionIndependentCode (
+ cmmMakeDynamicReference,
+ needImportedSymbols,
+ pprImportedSymbol,
+ pprGotDeclaration,
+ initializePicBase
+ ) where
+
+{-
+ This module handles generation of position independent code and
+ dynamic-linking related issues for the native code generator.
+
+ Things outside this module which are related to this:
+
+ + module CLabel
+ - PIC base label (pretty printed as local label 1)
+ - DynamicLinkerLabels - several kinds:
+ CodeStub, SymbolPtr, GotSymbolPtr, GotSymbolOffset
+ - labelDynamic predicate
+ + module Cmm
+ - The CmmExpr datatype has a CmmPicBaseReg constructor
+ - The CmmLit datatype has a CmmLabelDiffOff constructor
+ + codeGen & RTS
+ - When tablesNextToCode, no absolute addresses are stored in info tables
+ any more. Instead, offsets from the info label are used.
+ - For Win32 only, SRTs might contain addresses of __imp_ symbol pointers
+ because Win32 doesn't support external references in data sections.
+ TODO: make sure this still works, it might be bitrotted
+ + NCG
+ - The cmmToCmm pass in AsmCodeGen calls cmmMakeDynamicReference for all
+ labels.
+ - nativeCodeGen calls pprImportedSymbol and pprGotDeclaration to output
+ all the necessary stuff for imported symbols.
+ - The NCG monad keeps track of a list of imported symbols.
+ - MachCodeGen invokes initializePicBase to generate code to initialize
+ the PIC base register when needed.
+ - MachCodeGen calls cmmMakeDynamicReference whenever it uses a CLabel
+ that wasn't in the original Cmm code (e.g. floating point literals).
+ + The Mangler
+ - The mangler converts absolure refs to relative refs in info tables
+ - Symbol pointers, stub code and PIC calculations that are generated
+ by GCC are left intact by the mangler (so far only on ppc-darwin
+ and ppc-linux).
+-}
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+import Cmm
+import MachOp ( MachOp(MO_Add), wordRep )
+import CLabel ( CLabel, pprCLabel,
+ mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..),
+ dynamicLinkerLabelInfo, mkPicBaseLabel,
+ labelDynamic, externallyVisibleCLabel )
+
+import MachRegs
+import MachInstrs
+import NCGMonad ( NatM, getNewRegNat, getNewLabelNat )
+
+import CmdLineOpts ( opt_PIC )
+
+import Pretty
+import qualified Outputable
+
+import Panic ( panic )
+
+
+-- The most important function here is cmmMakeDynamicReference.
+
+-- It gets called by the cmmToCmm pass for every CmmLabel in the Cmm
+-- code. It does The Right Thing(tm) to convert the CmmLabel into a
+-- position-independent, dynamic-linking-aware reference to the thing
+-- in question.
+-- Note that this also has to be called from MachCodeGen in order to
+-- access static data like floating point literals (labels that were
+-- created after the cmmToCmm pass).
+-- The function must run in a monad that can keep track of imported symbols
+-- A function for recording an imported symbol must be passed in:
+-- - addImportCmmOpt for the CmmOptM monad
+-- - addImportNat for the NatM monad.
+
+cmmMakeDynamicReference
+ :: Monad m => (CLabel -> m ()) -- a monad & a function
+ -- used for recording imported symbols
+ -> Bool -- whether this is the target of a jump
+ -> CLabel -- the label
+ -> m CmmExpr
+
+cmmMakeDynamicReference addImport isJumpTarget lbl
+ | Just _ <- dynamicLinkerLabelInfo lbl
+ = return $ CmmLit $ CmmLabel lbl -- already processed it, pass through
+ | otherwise = case howToAccessLabel isJumpTarget lbl of
+ AccessViaStub -> do
+ let stub = mkDynamicLinkerLabel CodeStub lbl
+ addImport stub
+ return $ CmmLit $ CmmLabel stub
+ AccessViaSymbolPtr -> do
+ let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl
+ addImport symbolPtr
+ return $ CmmLoad (cmmMakePicReference symbolPtr) wordRep
+ AccessDirectly
+ -- all currently supported processors support
+ -- a PC-relative branch instruction, so just jump there
+ | isJumpTarget -> return $ CmmLit $ CmmLabel lbl
+ -- for data, we might have to make some calculations:
+ | otherwise -> return $ cmmMakePicReference lbl
+
+-- -------------------------------------------------------------------
+
+-- Create a position independent reference to a label.
+-- (but do not bother with dynamic linking).
+-- We calculate the label's address by adding some (platform-dependent)
+-- offset to our base register; this offset is calculated by
+-- the function picRelative in the platform-dependent part below.
+
+cmmMakePicReference :: CLabel -> CmmExpr
+
+#if !mingw32_TARGET_OS
+ -- Windows doesn't need PIC,
+ -- everything gets relocated at runtime
+
+cmmMakePicReference lbl
+ | opt_PIC && absoluteLabel lbl = CmmMachOp (MO_Add wordRep) [
+ CmmPicBaseReg,
+ CmmLit $ picRelative lbl
+ ]
+ where
+ absoluteLabel lbl = case dynamicLinkerLabelInfo lbl of
+ Just (GotSymbolPtr, _) -> False
+ Just (GotSymbolOffset, _) -> False
+ _ -> True
+
+#endif
+cmmMakePicReference lbl = CmmLit $ CmmLabel lbl
+
+-- ===================================================================
+-- Platform dependent stuff
+-- ===================================================================
+
+-- Knowledge about how special dynamic linker labels like symbol
+-- pointers, code stubs and GOT offsets look like is located in the
+-- module CLabel.
+
+-- -------------------------------------------------------------------
+
+-- We have to decide which labels need to be accessed
+-- indirectly or via a piece of stub code.
+
+data LabelAccessStyle = AccessViaStub
+ | AccessViaSymbolPtr
+ | AccessDirectly
+
+howToAccessLabel :: Bool -> CLabel -> LabelAccessStyle
+
+#if mingw32_TARGET_OS
+-- Windows
+--
+-- We need to use access *exactly* those things that
+-- are imported from a DLL via an __imp_* label.
+-- There are no stubs for imported code.
+
+howToAccessLabel _ lbl | labelDynamic lbl = AccessViaSymbolPtr
+ | otherwise = AccessDirectly
+
+#elif darwin_TARGET_OS
+-- Mach-O (Darwin, Mac OS X)
+--
+-- Indirect access is required in the following cases:
+-- * things imported from a dynamic library
+-- * things from a different module, if we're generating PIC code
+-- It is always possible to access something indirectly,
+-- even when it's not necessary.
+
+howToAccessLabel True lbl
+ -- jumps to a dynamic library go via a symbol stub
+ | labelDynamic lbl = AccessViaStub
+ -- when generating PIC code, all cross-module references must
+ -- must go via a symbol pointer, too.
+ -- Unfortunately, we don't know whether it's cross-module,
+ -- so we do it for all externally visible labels.
+ -- This is a slight waste of time and space, but otherwise
+ -- we'd need to pass the current Module all the way in to
+ -- this function.
+ | opt_PIC && externallyVisibleCLabel lbl = AccessViaStub
+howToAccessLabel False lbl
+ -- data access to a dynamic library goes via a symbol pointer
+ | labelDynamic lbl = AccessViaSymbolPtr
+ -- cross-module PIC references: same as above
+ | opt_PIC && externallyVisibleCLabel lbl = AccessViaSymbolPtr
+howToAccessLabel _ _ = AccessDirectly
+
+#elif linux_TARGET_OS && powerpc_TARGET_ARCH
+-- PowerPC Linux
+--
+-- PowerPC Linux is just plain broken.
+-- While it's theoretically possible to use GOT offsets larger
+-- than 16 bit, the standard crt*.o files don't, which leads to
+-- linker errors as soon as the GOT size exceeds 16 bit.
+-- Also, the assembler doesn't support @gotoff labels.
+-- In order to be able to use a larger GOT, we circumvent the
+-- entire GOT mechanism and do it ourselves (this is what GCC does).
+
+-- In this scheme, we need to do _all data references_ (even refs
+-- to static data) via a SymbolPtr when we are generating PIC.
+-- Luckily, the PLT works as expected, so we can simply access
+-- dynamically linked code via the PLT.
+
+howToAccessLabel _ _ | not opt_PIC = AccessDirectly
+howToAccessLabel True lbl
+ = if labelDynamic lbl then AccessViaStub
+ else AccessDirectly
+howToAccessLabel False lbl
+ = AccessViaSymbolPtr
+
+#elif linux_TARGET_OS
+-- ELF (Linux)
+--
+-- Indirect access is required for references to imported symbols
+-- from position independent code.
+-- It is always possible to access something indirectly,
+-- even when it's not necessary.
+
+-- For code, we can use a relative jump to a piece of
+-- stub code instead (this allows lazy binding of imported symbols).
+
+howToAccessLabel isJump lbl
+ -- no PIC -> the dynamic linker does everything for us
+ | not opt_PIC = AccessDirectly
+ -- if it's not imported, we need no indirection
+ -- ("foo" will end up being accessed as "foo@GOTOFF")
+ | not (labelDynamic lbl) = AccessDirectly
+#if !i386_TARGET_ARCH
+-- for Intel, we temporarily disable the use of the
+-- Procedure Linkage Table, because PLTs on intel require the
+-- address of the GOT to be loaded into register %ebx before
+-- a jump through the PLT is made.
+-- TODO: make the i386 NCG ensure this before jumping to a
+-- CodeStub label, so we can remove this special case.
+ | isJump = AccessViaStub
+#endif
+ | otherwise = AccessViaSymbolPtr
+#endif
+
+-- -------------------------------------------------------------------
+
+-- What do we have to add to our 'PIC base register' in order to
+-- get the address of a label?
+
+picRelative :: CLabel -> CmmLit
+#if darwin_TARGET_OS
+-- Darwin:
+-- The PIC base register points to the PIC base label at the beginning
+-- of the current CmmTop. We just have to use a label difference to
+-- get the offset.
+-- We have already made sure that all labels that are not from the current
+-- module are accessed indirectly ('as' can't calculate differences between
+-- undefined labels).
+
+picRelative lbl
+ = CmmLabelDiffOff lbl mkPicBaseLabel 0
+
+#elif powerpc_TARGET_ARCH && linux_TARGET_OS
+-- PowerPC Linux:
+-- The PIC base register points to our fake GOT. Use a label difference
+-- to get the offset.
+-- We have made sure that *everything* is accessed indirectly, so this
+-- is only used for offsets from the GOT to symbol pointers inside the
+-- GOT.
+picRelative lbl
+ = CmmLabelDiffOff lbl gotLabel 0
+
+#elif linux_TARGET_OS
+-- Other Linux versions:
+-- The PIC base register points to the GOT. Use foo@got for symbol
+-- pointers, and foo@gotoff for everything else.
+
+picRelative lbl
+ | Just (SymbolPtr, lbl') <- dynamicLinkerLabelInfo lbl
+ = CmmLabel $ mkDynamicLinkerLabel GotSymbolPtr lbl'
+ | otherwise
+ = CmmLabel $ mkDynamicLinkerLabel GotSymbolOffset lbl
+
+#else
+picRelative lbl = panic "PositionIndependentCode.picRelative"
+#endif
+
+-- -------------------------------------------------------------------
+
+-- What do we have to add to every assembly file we generate?
+
+-- utility function for pretty-printing asm-labels,
+-- copied from PprMach
+asmSDoc d = Outputable.withPprStyleDoc (
+ Outputable.mkCodeStyle Outputable.AsmStyle) d
+pprCLabel_asm l = asmSDoc (pprCLabel l)
+
+
+#if darwin_TARGET_OS
+
+needImportedSymbols = True
+
+-- We don't need to declare any offset tables
+pprGotDeclaration = Pretty.empty
+
+-- On Darwin, we have to generate our own stub code for lazy binding..
+-- There are two versions, one for PIC and one for non-PIC.
+pprImportedSymbol importedLbl
+ | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl
+ = case opt_PIC of
+ False ->
+ vcat [
+ ptext SLIT(".symbol_stub"),
+ ptext SLIT("L") <> pprCLabel_asm lbl <> ptext SLIT("$stub:"),
+ ptext SLIT("\t.indirect_symbol") <+> pprCLabel_asm lbl,
+ ptext SLIT("\tlis r11,ha16(L") <> pprCLabel_asm lbl
+ <> ptext SLIT("$lazy_ptr)"),
+ ptext SLIT("\tlwz r12,lo16(L") <> pprCLabel_asm lbl
+ <> ptext SLIT("$lazy_ptr)(r11)"),
+ ptext SLIT("\tmtctr r12"),
+ ptext SLIT("\taddi r11,r11,lo16(L") <> pprCLabel_asm lbl
+ <> ptext SLIT("$lazy_ptr)"),
+ ptext SLIT("\tbctr")
+ ]
+ True ->
+ vcat [
+ ptext SLIT(".section __TEXT,__picsymbolstub1,")
+ <> ptext SLIT("symbol_stubs,pure_instructions,32"),
+ ptext SLIT("L") <> pprCLabel_asm lbl <> ptext SLIT("$stub:"),
+ ptext SLIT("\t.indirect_symbol") <+> pprCLabel_asm lbl,
+ ptext SLIT("\tmflr r0"),
+ ptext SLIT("\tbcl 20,31,L0$") <> pprCLabel_asm lbl,
+ ptext SLIT("L0$") <> pprCLabel_asm lbl <> char ':',
+ ptext SLIT("\tmflr r11"),
+ ptext SLIT("\taddis r11,r11,ha16(L") <> pprCLabel_asm lbl
+ <> ptext SLIT("$lazy_ptr-L0$") <> pprCLabel_asm lbl <> char ')',
+ ptext SLIT("\tmtlr r0"),
+ ptext SLIT("\tlwzu r12,lo16(L") <> pprCLabel_asm lbl
+ <> ptext SLIT("$lazy_ptr-L0$") <> pprCLabel_asm lbl
+ <> ptext SLIT(")(r11)"),
+ ptext SLIT("\tmtctr r12"),
+ ptext SLIT("\tbctr")
+ ]
+ $+$ vcat [
+ ptext SLIT(".lazy_symbol_pointer"),
+ ptext SLIT("L") <> pprCLabel_asm lbl <> ptext SLIT("$lazy_ptr:"),
+ ptext SLIT("\t.indirect_symbol") <+> pprCLabel_asm lbl,
+ ptext SLIT("\t.long dyld_stub_binding_helper")
+ ]
+
+-- We also have to declare our symbol pointers ourselves:
+ | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl
+ = vcat [
+ ptext SLIT(".non_lazy_symbol_pointer"),
+ char 'L' <> pprCLabel_asm lbl <> ptext SLIT("$non_lazy_ptr:"),
+ ptext SLIT("\t.indirect_symbol") <+> pprCLabel_asm lbl,
+ ptext SLIT("\t.long\t0")
+ ]
+
+ | otherwise = empty
+
+#elif powerpc_TARGET_ARCH && linux_TARGET_OS
+
+-- For PowerPC linux, we don't do anything unless we're generating PIC.
+needImportedSymbols = opt_PIC
+
+-- If we're generating PIC, we need to create our own "fake GOT".
+
+gotLabel = mkForeignLabel -- HACK: it's not really foreign
+ FSLIT(".LCTOC1") Nothing False
+
+-- The .LCTOC1 label is defined to point 32768 bytes into the table,
+-- to make the most of the PPC's 16-bit displacements.
+
+pprGotDeclaration = vcat [
+ ptext SLIT(".section \".got2\",\"aw\""),
+ ptext SLIT(".LCTOC1 = .+32768")
+ ]
+
+-- We generate one .long literal for every symbol we import;
+-- the dynamic linker will relocate those addresses.
+
+pprImportedSymbol importedLbl
+ | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl
+ vcat [
+ ptext SLIT(".section \".got2\", \"aw\""),
+ ptext SLIT(".LC_") <> pprCLabel_asm lbl <> char ':',
+ ptext SLIT("\t.long") <+> pprCLabel_asm lbl
+ ]
+
+-- PLT code stubs are generated automatically be the dynamic linker.
+ | otherwise = empty
+
+#else
+
+-- For all other currently supported platforms, we don't need to do
+-- anything at all.
+
+needImportedSymbols = False
+pprGotDeclaration = Pretty.empty
+pprImportedSymbol _ = empty
+#endif
+
+-- -------------------------------------------------------------------
+
+-- Generate code to calculate the address that should be put in the
+-- PIC base register.
+-- This is called by MachCodeGen for every CmmProc that accessed the
+-- PIC base register. It adds the appropriate instructions to the
+-- top of the CmmProc.
+
+-- It is assumed that the first NatCmmTop in the input list is a Proc
+-- and the rest are CmmDatas.
+
+initializePicBase :: Reg -> [NatCmmTop] -> NatM [NatCmmTop]
+
+#if powerpc_TARGET_ARCH && darwin_TARGET_OS
+
+-- Darwin is simple: just fetch the address of a local label.
+initializePicBase picReg (CmmProc info lab params blocks : statics)
+ = return (CmmProc info lab params (b':tail blocks) : statics)
+ where BasicBlock bID insns = head blocks
+ b' = BasicBlock bID (FETCHPC picReg : insns)
+
+#elif powerpc_TARGET_ARCH && linux_TARGET_OS
+
+-- Get a pointer to our own fake GOT, which is defined on a per-module basis.
+-- This is exactly how GCC does it, and it's quite horrible:
+-- We first fetch the address of a local label (mkPicBaseLabel).
+-- Then we add a 16-bit offset to that to get the address of a .long that we
+-- define in .text space right next to the proc. This .long literal contains
+-- the (32-bit) offset from our local label to our global offset table
+-- (.LCTOC1 aka gotOffLabel).
+initializePicBase picReg
+ (CmmProc info lab params blocks : statics)
+ = do
+ gotOffLabel <- getNewLabelNat
+ tmp <- getNewRegNat wordRep
+ let
+ gotOffset = CmmData Text [
+ CmmDataLabel gotOffLabel,
+ CmmStaticLit (CmmLabelDiffOff gotLabel
+ mkPicBaseLabel
+ 0)
+ ]
+ offsetToOffset = ImmConstantDiff (ImmCLbl gotOffLabel)
+ (ImmCLbl mkPicBaseLabel)
+ BasicBlock bID insns = head blocks
+ b' = BasicBlock bID (FETCHPC picReg
+ : LD wordRep tmp
+ (AddrRegImm picReg offsetToOffset)
+ : ADD picReg picReg (RIReg tmp)
+ : insns)
+ return (CmmProc info lab params (b' : tail blocks) : gotOffset : statics)
+#else
+initializePicBase picReg proc = panic "initializePicBase"
+
+-- TODO:
+-- i386_TARGET_ARCH && linux_TARGET_OS:
+-- generate something like:
+-- call 1f
+-- 1: popl %picReg
+-- addl __GLOBAL_OFFSET_TABLE__+.-1b, %picReg
+-- It might be a good idea to use a FETCHPC pseudo-instruction (like for PowerPC)
+-- in order to avoid having to create a new basic block.
+-- ((FETCHPC reg) should pretty-print as call 1f; 1: popl reg)
+
+-- mingw32_TARGET_OS: not needed, won't be called
+
+-- i386_TARGET_ARCH && darwin_TARGET_OS:
+-- (just for completeness ;-)
+-- call 1f
+-- 1: popl %picReg
+#endif
diff --git a/ghc/compiler/nativeGen/PprMach.hs b/ghc/compiler/nativeGen/PprMach.hs
index 64ee5c6a1a20c4e6695afcb89d5ac1bc0025aef1..846a8555085fe853081445401107d88222e776f9 100644
--- a/ghc/compiler/nativeGen/PprMach.hs
+++ b/ghc/compiler/nativeGen/PprMach.hs
@@ -15,9 +15,6 @@
module PprMach (
pprNatCmmTop, pprBasicBlock,
pprInstr, pprSize, pprUserReg,
-#if darwin_TARGET_OS
- pprDyldSymbolStub,
-#endif
) where
@@ -37,6 +34,8 @@ import Pretty
import FastString
import qualified Outputable
+import CmdLineOpts ( opt_PIC )
+
#if __GLASGOW_HASKELL__ >= 504
import Data.Array.ST
import Data.Word ( Word8 )
@@ -378,15 +377,17 @@ pprImm :: Imm -> Doc
pprImm (ImmInt i) = int i
pprImm (ImmInteger i) = integer i
-pprImm (ImmCLbl l) = (if labelDynamic l then text "__imp_" else empty)
- <> pprCLabel_asm l
-pprImm (ImmIndex l i) = (if labelDynamic l then text "__imp_" else empty)
- <> pprCLabel_asm l <> char '+' <> int i
+pprImm (ImmCLbl l) = pprCLabel_asm l
+pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
pprImm (ImmLit s) = s
pprImm (ImmFloat _) = panic "pprImm:ImmFloat"
pprImm (ImmDouble _) = panic "pprImm:ImmDouble"
+pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
+pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
+ <> lparen <> pprImm b <> rparen
+
#if sparc_TARGET_ARCH
pprImm (LO i)
= hcat [ pp_lo, pprImm i, rparen ]
@@ -415,9 +416,6 @@ pprImm (HA i)
where
pp_ha = text "ha16("
-pprImm (ImmDyldNonLazyPtr lbl)
- = ptext SLIT("L") <> pprCLabel_asm lbl <> ptext SLIT("$non_lazy_ptr")
-
#else
pprImm (LO i)
= pprImm i <> text "@l"
@@ -643,7 +641,9 @@ pprInstr (COMMENT s)
= IF_ARCH_alpha( ((<>) (ptext SLIT("\t# ")) (ftext s))
,IF_ARCH_sparc( ((<>) (ptext SLIT("! ")) (ftext s))
,IF_ARCH_i386( ((<>) (ptext SLIT("# ")) (ftext s))
- ,IF_ARCH_powerpc( ((<>) (ptext SLIT("; ")) (ftext s))
+ ,IF_ARCH_powerpc( IF_OS_linux(
+ ((<>) (ptext SLIT("# ")) (ftext s)),
+ ((<>) (ptext SLIT("; ")) (ftext s)))
,))))
pprInstr (DELTA d)
@@ -1958,9 +1958,8 @@ pprInstr (BCTR _) = hcat [
ptext SLIT("bctr")
]
pprInstr (BL lbl _) = hcat [
- ptext SLIT("\tbl\tL"),
- pprCLabel_asm lbl,
- ptext SLIT("$stub")
+ ptext SLIT("\tbl\t"),
+ pprCLabel_asm lbl
]
pprInstr (BCTRL _) = hcat [
char '\t',
@@ -2089,6 +2088,18 @@ pprInstr (MFCR reg) = hcat [
pprReg reg
]
+pprInstr (MFLR reg) = hcat [
+ char '\t',
+ ptext SLIT("mflr"),
+ char '\t',
+ pprReg reg
+ ]
+
+pprInstr (FETCHPC reg) = vcat [
+ ptext SLIT("\tbcl\t20,31,1f"),
+ hcat [ ptext SLIT("1:\tmflr\t"), pprReg reg ]
+ ]
+
pprInstr _ = panic "pprInstr (ppc)"
pprLogic op reg1 reg2 ri = hcat [
@@ -2139,43 +2150,6 @@ limitShiftRI :: RI -> RI
limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
limitShiftRI x = x
-{-
- The Mach-O object file format used in Darwin/Mac OS X needs a so-called
- "symbol stub" for every function that might be imported from a dynamic
- library.
- The stubs are always the same, and they are all output at the end of the
- generated assembly (see AsmCodeGen.lhs), so we don't use the Instr datatype.
- Instead, we just pretty-print it directly.
--}
-
-#if darwin_TARGET_OS
-pprDyldSymbolStub (True, lbl) =
- vcat [
- ptext SLIT(".symbol_stub"),
- ptext SLIT("L") <> pprLbl <> ptext SLIT("$stub:"),
- ptext SLIT("\t.indirect_symbol") <+> pprLbl,
- ptext SLIT("\tlis r11,ha16(L") <> pprLbl <> ptext SLIT("$lazy_ptr)"),
- ptext SLIT("\tlwz r12,lo16(L") <> pprLbl <> ptext SLIT("$lazy_ptr)(r11)"),
- ptext SLIT("\tmtctr r12"),
- ptext SLIT("\taddi r11,r11,lo16(L") <> pprLbl <> ptext SLIT("$lazy_ptr)"),
- ptext SLIT("\tbctr"),
- ptext SLIT(".lazy_symbol_pointer"),
- ptext SLIT("L") <> pprLbl <> ptext SLIT("$lazy_ptr:"),
- ptext SLIT("\t.indirect_symbol") <+> pprLbl,
- ptext SLIT("\t.long dyld_stub_binding_helper")
- ]
- where pprLbl = pprCLabel_asm lbl
-
-pprDyldSymbolStub (False, lbl) =
- vcat [
- ptext SLIT(".non_lazy_symbol_pointer"),
- char 'L' <> pprLbl <> ptext SLIT("$non_lazy_ptr:"),
- ptext SLIT("\t.indirect_symbol") <+> pprLbl,
- ptext SLIT("\t.long\t0")
- ]
- where pprLbl = pprCLabel_asm lbl
-#endif
-
#endif /* powerpc_TARGET_ARCH */
diff --git a/ghc/compiler/nativeGen/RegAllocInfo.hs b/ghc/compiler/nativeGen/RegAllocInfo.hs
index da2727b387af21c2e39fbf727251e1fad9d494da..c1c259a2187f834e03b412f805ec088cbdccea35 100644
--- a/ghc/compiler/nativeGen/RegAllocInfo.hs
+++ b/ghc/compiler/nativeGen/RegAllocInfo.hs
@@ -344,6 +344,8 @@ regUsage instr = case instr of
FCTIWZ r1 r2 -> usage ([r2], [r1])
FRSP r1 r2 -> usage ([r2], [r1])
MFCR reg -> usage ([], [reg])
+ MFLR reg -> usage ([], [reg])
+ FETCHPC reg -> usage ([], [reg])
_ -> noUsage
where
usage (src, dst) = RU (filter interesting src)
@@ -621,6 +623,8 @@ patchRegs instr env = case instr of
FCTIWZ r1 r2 -> FCTIWZ (env r1) (env r2)
FRSP r1 r2 -> FRSP (env r1) (env r2)
MFCR reg -> MFCR (env reg)
+ MFLR reg -> MFLR (env reg)
+ FETCHPC reg -> FETCHPC (env reg)
_ -> instr
where
fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2)
diff --git a/ghc/driver/mangler/ghc-asm.lprl b/ghc/driver/mangler/ghc-asm.lprl
index be72f7fd5f8e570d210c5c2dcf164ea29bbe63ff..259d6add56afac457545d1ff6e5cd05cec7e6515 100644
--- a/ghc/driver/mangler/ghc-asm.lprl
+++ b/ghc/driver/mangler/ghc-asm.lprl
@@ -562,6 +562,11 @@ sub mangle_asm {
$chkcat[$i] = 'data';
$chksymb[$i] = '';
+ } elsif ( /^${T_US}(stg_ap_stack_entries|stg_stack_save_entries|stg_arg_bitmaps)${T_POST_LBL}$/o ) {
+ $chk[++$i] = $_;
+ $chkcat[$i] = 'data';
+ $chksymb[$i] = '';
+
} elsif ( /^(${T_US}__gnu_compiled_c|gcc2_compiled\.)${T_POST_LBL}/o ) {
; # toss it
@@ -638,8 +643,10 @@ sub mangle_asm {
} elsif ( $TargetPlatform =~ /^powerpc-apple-.*/ && (
/^\.picsymbol_stub/
|| /^\.section __TEXT,__picsymbol_stub1,.*/
+ || /^\.section __TEXT,__picsymbolstub1,.*/
|| /^\.symbol_stub/
|| /^\.section __TEXT,__symbol_stub1,.*/
+ || /^\.section __TEXT,__symbolstub1,.*/
|| /^\.lazy_symbol_pointer/
|| /^\.non_lazy_symbol_pointer/ ))
{
@@ -651,6 +658,16 @@ sub mangle_asm {
$chk[++$i] = $_;
$chkcat[$i] = 'dyld';
$chksymb[$i] = '';
+ } elsif ( $TargetPlatform =~ /^powerpc-.*-linux/ && /^\.LCTOC1 = /o ) {
+ # PowerPC Linux's large-model PIC (-fPIC) generates a gobal offset
+ # table "by hand". Be sure to copy it over.
+ # Note that this label and all entries in the table should actually
+ # go into the .got2 section, but it isn't easy to distinguish them
+ # from other constant literals (.LC\d+), so we just put everything
+ # in .rodata.
+ $chk[++$i] = $_;
+ $chkcat[$i] = 'literal';
+ $chksymb[$i] = 'LCTOC1';
} else { # simple line (duplicated at the top)
$chk[$i] .= $_;
@@ -763,12 +780,12 @@ sub mangle_asm {
$p =~ s/__FRAME__/$FRAME/;
} elsif ($TargetPlatform =~ /^powerpc-apple-.*/) {
$pcrel_label = $p;
- $pcrel_label =~ s/(.|\n)*^(L\d+\$pb):\n(.|\n)*/$2/ or $pcrel_label = "";
+ $pcrel_label =~ s/(.|\n)*^(\"?L\d+\$pb\"?):\n(.|\n)*/$2/ or $pcrel_label = "";
$p =~ s/^\tmflr r0\n//;
$p =~ s/^\tbl saveFP # f\d+\n//;
$p =~ s/^\tbl saveFP ; save f\d+-f\d+\n//;
- $p =~ s/^L\d+\$pb:\n//;
+ $p =~ s/^\"?L\d+\$pb\"?:\n//;
$p =~ s/^\tstmw r\d+,-\d+\(r1\)\n//;
$p =~ s/^\tstfd f\d+,-\d+\(r1\)\n//g;
$p =~ s/^\tstw r0,\d+\(r1\)\n//g;
@@ -790,6 +807,16 @@ sub mangle_asm {
$p =~ s/^\tstw r0,8\(1\)\n//;
$p =~ s/^\tstwu 1,-\d+\(1\)\n//;
$p =~ s/^\tstw \d+,\d+\(1\)\n//g;
+
+ # GCC's "large-model" PIC (-fPIC)
+ $pcrel_label = $p;
+ $pcrel_label =~ s/(.|\n)*^.LCF(\d+):\n(.|\n)*/$2/ or $pcrel_label = "";
+
+ $p =~ s/^\tbcl 20,31,.LCF\d+\n//;
+ $p =~ s/^.LCF\d+:\n//;
+ $p =~ s/^\tmflr 30\n//;
+ $p =~ s/^\tlwz 0,\.LCL\d+-\.LCF\d+\(30\)\n//;
+ $p =~ s/^\tadd 30,0,30\n//;
# This is bad: GCC 3 seems to zero-fill some local variables in the prologue
# under some circumstances, only when generating position dependent code.
@@ -804,13 +831,20 @@ sub mangle_asm {
#print stderr "HWL: this should die! Prologue junk?: $p\n" if $p =~ /^\t[^\.]/;
die "Prologue junk?: $p\n" if $p =~ /^\s+[^\s\.]/;
+ # For PIC, we want to keep part of the prologue
if ($TargetPlatform =~ /^powerpc-apple-.*/ && $pcrel_label ne "") {
- # on PowerPC, we have to keep a part of the prologue
- # (which loads the current instruction pointer into register r31)
+ # Darwin: load the current instruction pointer into register r31
$p .= "bcl 20,31,$pcrel_label\n";
$p .= "$pcrel_label:\n";
$p .= "\tmflr r31\n";
- }
+ } elsif ($TargetPlatform =~ /^powerpc-.*-linux/ && $pcrel_label ne "") {
+ # Linux: load the GOT pointer into register 30
+ $p .= "\tbcl 20,31,.LCF$pcrel_label\n";
+ $p .= ".LCF$pcrel_label:\n";
+ $p .= "\tmflr 30\n";
+ $p .= "\tlwz 0,.LCL$pcrel_label-.LCF$pcrel_label(30)\n";
+ $p .= "\tadd 30,0,30\n";
+ }
# glue together what's left
$c = $p . $r;
@@ -886,7 +920,7 @@ sub mangle_asm {
$c =~ s/^\t(call|jbsr|jal)\s+${T_US}__DISCARD__\n//go;
$c =~ s/^\tjsr\s+\$26\s*,\s*${T_US}__DISCARD__\n//go if $TargetPlatform =~ /^alpha-/;
$c =~ s/^\tbl\s+L___DISCARD__\$stub\n//go if $TargetPlatform =~ /^powerpc-apple-.*/;
- $c =~ s/^\tbl\s+__DISCARD__\n//go if $TargetPlatform =~ /^powerpc-.*-linux/;
+ $c =~ s/^\tbl\s+__DISCARD__(\@plt)?\n//go if $TargetPlatform =~ /^powerpc-.*-linux/;
# IA64: mangle tailcalls into jumps here
if ($TargetPlatform =~ /^ia64-/) {
@@ -1362,13 +1396,30 @@ sub rev_tbl {
$before .= $lines[$i] . "\n"; # otherwise...
}
+ $infoname = $label;
+ $infoname =~ s/(.|\n)*^([A-Za-z0-9_]+_info)${T_POST_LBL}$(.|\n)*/\2/;
+
# Grab the table data...
if ( $TargetPlatform !~ /^hppa/ ) {
for ( ; $i <= $#lines && $lines[$i] =~ /^\t?${T_DOT_WORD}\s+/o; $i++) {
- push(@words, $lines[$i]);
+ $line = $lines[$i];
+ # Convert addresses of SRTs, slow entrypoints and large bitmaps
+ # to offsets (relative to the info label),
+ # in order to support position independent code.
+ $line =~ s/$infoname/0/
+ || $line =~ s/([A-Za-z0-9_]+_srtd)$/\1 - $infoname/
+ || $line =~ s/([A-Za-z0-9_]+_srt(\+\d+)?)$/\1 - $infoname/
+ || $line =~ s/([A-Za-z0-9_]+_slow)$/\1 - $infoname/
+ || $line =~ s/([A-Za-z0-9_]+_btm)$/\1 - $infoname/
+ || $line =~ s/([A-Za-z0-9_]+_alt)$/\1 - $infoname/
+ || $line =~ s/([A-Za-z0-9_]+_dflt)$/\1 - $infoname/
+ || $line =~ s/([A-Za-z0-9_]+_ret)$/\1 - $infoname/;
+ push(@words, $line);
}
} else { # hppa weirdness
for ( ; $i <= $#lines && $lines[$i] =~ /^\s+(${T_DOT_WORD}|\.IMPORT)/; $i++) {
+ # FIXME: the RTS now expects offsets instead of addresses
+ # for all labels in info tables.
if ($lines[$i] =~ /^\s+\.IMPORT/) {
push(@imports, $lines[$i]);
} else {
diff --git a/ghc/includes/Cmm.h b/ghc/includes/Cmm.h
index 608e97dfbdfc5a033f64e1064b4c75d4fe4af0d4..0dde2c82c155cbac99177d44c1775b8cb5175c62 100644
--- a/ghc/includes/Cmm.h
+++ b/ghc/includes/Cmm.h
@@ -346,7 +346,13 @@
// macros which use the appropriate version here:
//
#ifdef TABLES_NEXT_TO_CODE
-#define StgFunInfoExtra_slow_apply(i) StgFunInfoExtraRev_slow_apply(i)
+ // when TABLES_NEXT_TO_CODE, slow_apply is stored as an offset
+ // instead of the normal pointer.
+
+#define StgFunInfoExtra_slow_apply(fun_info) \
+ (StgFunInfoExtraRev_slow_apply_offset(fun_info) \
+ + (fun_info) + SIZEOF_StgFunInfoExtraRev + SIZEOF_StgInfoTable)
+
#define StgFunInfoExtra_fun_type(i) StgFunInfoExtraRev_fun_type(i)
#define StgFunInfoExtra_arity(i) StgFunInfoExtraRev_arity(i)
#define StgFunInfoExtra_bitmap(i) StgFunInfoExtraRev_bitmap(i)
diff --git a/ghc/includes/InfoTables.h b/ghc/includes/InfoTables.h
index a605ba2c177ccdfd0f16e1f6476f3b45c6980ddd..f3a118203e800b26a85ca2623d6f8da92ea180a1 100644
--- a/ghc/includes/InfoTables.h
+++ b/ghc/includes/InfoTables.h
@@ -1,5 +1,5 @@
/* ----------------------------------------------------------------------------
- * $Id: InfoTables.h,v 1.33 2004/08/13 13:09:17 simonmar Exp $
+ * $Id: InfoTables.h,v 1.34 2004/10/07 15:54:26 wolfgang Exp $
*
* (c) The GHC Team, 1998-2002
*
@@ -232,7 +232,11 @@ typedef union {
StgWord bitmap; // word-sized bit pattern describing
// a stack frame: see below
+#ifndef TABLES_NEXT_TO_CODE
StgLargeBitmap* large_bitmap; // pointer to large bitmap structure
+#else
+ StgWord large_bitmap_offset; // offset from info table to large bitmap structure
+#endif
StgWord selector_offset; // used in THUNK_SELECTORs
@@ -288,9 +292,9 @@ typedef struct _StgInfoTable {
-------------------------------------------------------------------------- */
typedef struct _StgFunInfoExtraRev {
- StgFun *slow_apply; // apply to args on the stack
+ StgWord slow_apply_offset; // apply to args on the stack
StgWord bitmap; // arg ptr/nonptr bitmap
- StgSRT *srt; // pointer to the SRT table
+ StgWord srt_offset; // pointer to the SRT table
StgHalfWord fun_type; // function type
StgHalfWord arity; // function arity
} StgFunInfoExtraRev;
@@ -322,7 +326,7 @@ typedef struct {
typedef struct {
#if defined(TABLES_NEXT_TO_CODE)
- StgSRT *srt; // pointer to the SRT table
+ StgWord srt_offset; // offset to the SRT table
StgInfoTable i;
#else
StgInfoTable i;
@@ -342,10 +346,50 @@ typedef struct _StgThunkInfoTable {
#if !defined(TABLES_NEXT_TO_CODE)
StgInfoTable i;
#endif
+#if defined(TABLES_NEXT_TO_CODE)
+ StgWord srt_offset; // offset to the SRT table
+#else
StgSRT *srt; // pointer to the SRT table
+#endif
#if defined(TABLES_NEXT_TO_CODE)
StgInfoTable i;
#endif
} StgThunkInfoTable;
+
+/* -----------------------------------------------------------------------------
+ Accessor macros for fields that might be offsets (C version)
+ -------------------------------------------------------------------------- */
+
+// GET_SRT(info)
+// info must be a Stg[Ret|Thunk]InfoTable* (an info table that has a SRT)
+#ifdef TABLES_NEXT_TO_CODE
+#define GET_SRT(info) ((StgSRT*) (((StgWord) ((info)+1)) + (info)->srt_offset))
+#else
+#define GET_SRT(info) ((info)->srt)
+#endif
+
+// GET_FUN_SRT(info)
+// info must be a StgFunInfoTable*
+#ifdef TABLES_NEXT_TO_CODE
+#define GET_FUN_SRT(info) ((StgSRT*) (((StgWord) ((info)+1)) + (info)->f.srt_offset))
+#else
+#define GET_FUN_SRT(info) ((info)->f.srt)
+#endif
+
+#ifdef TABLES_NEXT_TO_CODE
+#define GET_LARGE_BITMAP(info) ((StgLargeBitmap*) (((StgWord) ((info)+1)) \
+ + (info)->layout.large_bitmap_offset))
+#else
+#define GET_LARGE_BITMAP(info) ((info)->layout.large_bitmap)
+#endif
+
+#ifdef TABLES_NEXT_TO_CODE
+#define GET_FUN_LARGE_BITMAP(info) ((StgLargeBitmap*) (((StgWord) ((info)+1)) \
+ + (info)->f.bitmap))
+#else
+#define GET_FUN_LARGE_BITMAP(info) ((StgLargeBitmap*) ((info)->f.bitmap))
+#endif
+
+
#endif /* INFOTABLES_H */
diff --git a/ghc/includes/Storage.h b/ghc/includes/Storage.h
index eb3c71639dc4544455c30e9469cba33c86870cf6..5c7609460f09a468c7504c147fbd4b381238ab4e 100644
--- a/ghc/includes/Storage.h
+++ b/ghc/includes/Storage.h
@@ -333,7 +333,7 @@ INLINE_HEADER StgWord stack_frame_sizeW( StgClosure *frame )
case RET_BIG:
case RET_VEC_BIG:
- return 1 + info->i.layout.large_bitmap->size;
+ return 1 + GET_LARGE_BITMAP(&info->i)->size;
case RET_BCO:
return 2 + BCO_BITMAP_SIZE((StgBCO *)((P_)frame)[1]);
diff --git a/ghc/includes/mkDerivedConstants.c b/ghc/includes/mkDerivedConstants.c
index f5d62139329bda858d761d340a3b06144406b20f..71791fd81573d1403b17163eb8331ca2fd8fd6df 100644
--- a/ghc/includes/mkDerivedConstants.c
+++ b/ghc/includes/mkDerivedConstants.c
@@ -346,7 +346,7 @@ main(int argc, char *argv[])
struct_field(StgFunInfoExtraFwd, bitmap);
struct_size(StgFunInfoExtraRev);
- struct_field(StgFunInfoExtraRev, slow_apply);
+ struct_field(StgFunInfoExtraRev, slow_apply_offset);
struct_field(StgFunInfoExtraRev, fun_type);
struct_field(StgFunInfoExtraRev, arity);
struct_field(StgFunInfoExtraRev, bitmap);
diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c
index 735b0518abfec05614011934a7dd474ce4828077..25f794f16a34e4499837f68160c413dfaf4ac1b3 100644
--- a/ghc/rts/GC.c
+++ b/ghc/rts/GC.c
@@ -2303,7 +2303,7 @@ scavenge_thunk_srt(const StgInfoTable *info)
StgThunkInfoTable *thunk_info;
thunk_info = itbl_to_thunk_itbl(info);
- scavenge_srt((StgClosure **)thunk_info->srt, thunk_info->i.srt_bitmap);
+ scavenge_srt((StgClosure **)GET_SRT(thunk_info), thunk_info->i.srt_bitmap);
}
STATIC_INLINE void
@@ -2312,7 +2312,7 @@ scavenge_fun_srt(const StgInfoTable *info)
StgFunInfoTable *fun_info;
fun_info = itbl_to_fun_itbl(info);
- scavenge_srt((StgClosure **)fun_info->f.srt, fun_info->i.srt_bitmap);
+ scavenge_srt((StgClosure **)GET_FUN_SRT(fun_info), fun_info->i.srt_bitmap);
}
STATIC_INLINE void
@@ -2321,7 +2321,7 @@ scavenge_ret_srt(const StgInfoTable *info)
StgRetInfoTable *ret_info;
ret_info = itbl_to_ret_itbl(info);
- scavenge_srt((StgClosure **)ret_info->srt, ret_info->i.srt_bitmap);
+ scavenge_srt((StgClosure **)GET_SRT(ret_info), ret_info->i.srt_bitmap);
}
/* -----------------------------------------------------------------------------
@@ -2371,8 +2371,8 @@ scavenge_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
size = BITMAP_SIZE(fun_info->f.bitmap);
goto small_bitmap;
case ARG_GEN_BIG:
- size = ((StgLargeBitmap *)fun_info->f.bitmap)->size;
- scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap, size);
+ size = GET_FUN_LARGE_BITMAP(fun_info)->size;
+ scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
p += size;
break;
default:
@@ -2411,7 +2411,7 @@ scavenge_PAP (StgPAP *pap)
bitmap = BITMAP_BITS(fun_info->f.bitmap);
goto small_bitmap;
case ARG_GEN_BIG:
- scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap, size);
+ scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
p += size;
break;
case ARG_BCO:
@@ -3772,7 +3772,7 @@ scavenge_stack(StgPtr p, StgPtr stack_end)
p = scavenge_small_bitmap(p, size, bitmap);
follow_srt:
- scavenge_srt((StgClosure **)info->srt, info->i.srt_bitmap);
+ scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
continue;
case RET_BCO: {
@@ -3795,9 +3795,9 @@ scavenge_stack(StgPtr p, StgPtr stack_end)
{
nat size;
- size = info->i.layout.large_bitmap->size;
+ size = GET_LARGE_BITMAP(&info->i)->size;
p++;
- scavenge_large_bitmap(p, info->i.layout.large_bitmap, size);
+ scavenge_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
p += size;
// and don't forget to follow the SRT
goto follow_srt;
diff --git a/ghc/rts/GCCompact.c b/ghc/rts/GCCompact.c
index 0e2129fa95c5cd82c92b503077b4e6ddef6e8cdd..6dd0131d19400ed2bc4580ba0af36e711baace87 100644
--- a/ghc/rts/GCCompact.c
+++ b/ghc/rts/GCCompact.c
@@ -218,8 +218,8 @@ thread_arg_block (StgFunInfoTable *fun_info, StgClosure **args)
size = BITMAP_SIZE(fun_info->f.bitmap);
goto small_bitmap;
case ARG_GEN_BIG:
- size = ((StgLargeBitmap *)fun_info->f.bitmap)->size;
- thread_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap, size);
+ size = GET_FUN_LARGE_BITMAP(fun_info)->size;
+ thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
p += size;
break;
default:
@@ -327,8 +327,8 @@ thread_stack(StgPtr p, StgPtr stack_end)
case RET_BIG:
case RET_VEC_BIG:
p++;
- size = info->i.layout.large_bitmap->size;
- thread_large_bitmap(p, info->i.layout.large_bitmap, size);
+ size = GET_LARGE_BITMAP(&info->i)->size;
+ thread_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
p += size;
continue;
@@ -370,7 +370,7 @@ thread_PAP (StgPAP *pap)
bitmap = BITMAP_BITS(fun_info->f.bitmap);
goto small_bitmap;
case ARG_GEN_BIG:
- thread_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap, size);
+ thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
p += size;
break;
case ARG_BCO:
diff --git a/ghc/rts/HeapStackCheck.cmm b/ghc/rts/HeapStackCheck.cmm
index 6e8eba5737d33ccf4b10b2e568a712e7aa5daa78..2a264b2aa02d8e38fbaad03fe045ccb67f6def8e 100644
--- a/ghc/rts/HeapStackCheck.cmm
+++ b/ghc/rts/HeapStackCheck.cmm
@@ -594,7 +594,13 @@ __stg_gc_fun
size = BITMAP_SIZE(StgFunInfoExtra_bitmap(info));
} else {
if (type == ARG_GEN_BIG) {
+#ifdef TABLES_NEXT_TO_CODE
+ // bitmap field holds an offset
+ size = StgLargeBitmap_size( StgFunInfoExtra_bitmap(info)
+ + %GET_ENTRY(R1) /* ### */ );
+#else
size = StgLargeBitmap_size( StgFunInfoExtra_bitmap(info) );
+#endif
} else {
size = BITMAP_SIZE(W_[stg_arg_bitmaps + WDS(type)]);
}
diff --git a/ghc/rts/Linker.c b/ghc/rts/Linker.c
index 5058294c358ca99ebfae7be05cdb04a12c86c28b..1f53d3823d78ad5f2ef906826a11c6de3c5bc7e2 100644
--- a/ghc/rts/Linker.c
+++ b/ghc/rts/Linker.c
@@ -3814,14 +3814,24 @@ static int ocResolve_MachO(ObjectCode* oc)
static void machoInitSymbolsWithoutUnderscore()
{
- void *p;
+ extern void* symbolsWithoutUnderscore[];
+ void **p = symbolsWithoutUnderscore;
+ __asm__ volatile(".data\n_symbolsWithoutUnderscore:");
#undef Sym
-#define Sym(x) \
- __asm__ ("lis %0,hi16(" #x ")\n\tori %0,%0,lo16(" #x ")" : "=r" (p)); \
- ghciInsertStrHashTable("(GHCi built-in symbols)", symhash, #x, p);
+#define Sym(x) \
+ __asm__ volatile(".long " # x);
RTS_MACHO_NOUNDERLINE_SYMBOLS
+ __asm__ volatile(".text");
+
+#undef Sym
+#define Sym(x) \
+ ghciInsertStrHashTable("(GHCi built-in symbols)", symhash, #x, *p++);
+
+ RTS_MACHO_NOUNDERLINE_SYMBOLS
+
+#undef Sym
}
#endif
diff --git a/ghc/rts/Printer.c b/ghc/rts/Printer.c
index c72b33a5acbffe415c18fe374b014ad6a6759628..9e8d09043c69e3a85c06fad362168ba054c33ac0 100644
--- a/ghc/rts/Printer.c
+++ b/ghc/rts/Printer.c
@@ -622,8 +622,8 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
break;
case ARG_GEN_BIG:
printLargeBitmap(spBottom, sp+2,
- (StgLargeBitmap *)fun_info->f.bitmap,
- BITMAP_SIZE(fun_info->f.bitmap));
+ GET_FUN_LARGE_BITMAP(fun_info),
+ GET_FUN_LARGE_BITMAP(fun_info)->size);
break;
default:
printSmallBitmap(spBottom, sp+1,
diff --git a/ghc/rts/RetainerProfile.c b/ghc/rts/RetainerProfile.c
index 5cd881f6046217f3f06e01dd213a7caa0b149dd0..04b65830b01dba7dd0ae12084568d9ad11bb5edf 100644
--- a/ghc/rts/RetainerProfile.c
+++ b/ghc/rts/RetainerProfile.c
@@ -329,11 +329,11 @@ init_srt_fun( stackPos *info, StgFunInfoTable *infoTable )
{
if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
info->type = posTypeLargeSRT;
- info->next.large_srt.srt = (StgLargeSRT *)infoTable->f.srt;
+ info->next.large_srt.srt = (StgLargeSRT *)GET_FUN_SRT(infoTable);
info->next.large_srt.offset = 0;
} else {
info->type = posTypeSRT;
- info->next.srt.srt = (StgClosure **)(infoTable->f.srt);
+ info->next.srt.srt = (StgClosure **)GET_FUN_SRT(infoTable);
info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
}
}
@@ -343,11 +343,11 @@ init_srt_thunk( stackPos *info, StgThunkInfoTable *infoTable )
{
if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
info->type = posTypeLargeSRT;
- info->next.large_srt.srt = (StgLargeSRT *)infoTable->srt;
+ info->next.large_srt.srt = (StgLargeSRT *)GET_SRT(infoTable);
info->next.large_srt.offset = 0;
} else {
info->type = posTypeSRT;
- info->next.srt.srt = (StgClosure **)(infoTable->srt);
+ info->next.srt.srt = (StgClosure **)GET_SRT(infoTable);
info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
}
}
@@ -1319,7 +1319,7 @@ retainStack( StgClosure *c, retainer c_child_r,
p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
follow_srt:
- retainSRT((StgClosure **)info->srt, info->i.srt_bitmap, c, c_child_r);
+ retainSRT((StgClosure **)GET_SRT(info), info->i.srt_bitmap, c, c_child_r);
continue;
case RET_BCO: {
@@ -1338,9 +1338,9 @@ retainStack( StgClosure *c, retainer c_child_r,
// large bitmap (> 32 entries, or > 64 on a 64-bit machine)
case RET_BIG:
case RET_VEC_BIG:
- size = info->i.layout.large_bitmap->size;
+ size = GET_LARGE_BITMAP(&info->i)->size;
p++;
- retain_large_bitmap(p, info->i.layout.large_bitmap,
+ retain_large_bitmap(p, GET_LARGE_BITMAP(&info->i),
size, c, c_child_r);
p += size;
// and don't forget to follow the SRT
@@ -1383,8 +1383,8 @@ retainStack( StgClosure *c, retainer c_child_r,
p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
break;
case ARG_GEN_BIG:
- size = ((StgLargeBitmap *)fun_info->f.bitmap)->size;
- retain_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap,
+ size = GET_FUN_LARGE_BITMAP(fun_info)->size;
+ retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
size, c, c_child_r);
p += size;
break;
@@ -1439,7 +1439,7 @@ retain_PAP (StgPAP *pap, retainer c_child_r)
(StgClosure *)pap, c_child_r);
break;
case ARG_GEN_BIG:
- retain_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap,
+ retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
size, (StgClosure *)pap, c_child_r);
p += size;
break;
diff --git a/ghc/rts/Sanity.c b/ghc/rts/Sanity.c
index d4c3dca9c0508cb771cb0c2482e320535116b1c2..43e7b5ad49b4e6f571e187a7aebeb95301aa5bdc 100644
--- a/ghc/rts/Sanity.c
+++ b/ghc/rts/Sanity.c
@@ -151,8 +151,8 @@ checkStackFrame( StgPtr c )
case RET_BIG: // large bitmap (> 32 entries)
case RET_VEC_BIG:
- size = info->i.layout.large_bitmap->size;
- checkLargeBitmap((StgPtr)c + 1, info->i.layout.large_bitmap, size);
+ size = GET_LARGE_BITMAP(&info->i)->size;
+ checkLargeBitmap((StgPtr)c + 1, GET_LARGE_BITMAP(&info->i), size);
return 1 + size;
case RET_FUN:
@@ -170,7 +170,7 @@ checkStackFrame( StgPtr c )
break;
case ARG_GEN_BIG:
checkLargeBitmap((StgPtr)ret_fun->payload,
- (StgLargeBitmap *)fun_info->f.bitmap, size);
+ GET_FUN_LARGE_BITMAP(fun_info), size);
break;
default:
checkSmallBitmap((StgPtr)ret_fun->payload,
@@ -360,7 +360,7 @@ checkClosure( StgClosure* p )
break;
case ARG_GEN_BIG:
checkLargeBitmap( (StgPtr)pap->payload,
- (StgLargeBitmap *)fun_info->f.bitmap,
+ GET_FUN_LARGE_BITMAP(fun_info),
pap->n_args );
break;
case ARG_BCO: