From b4d045ae655e5eae25b88917cfe75d7dc7689c21 Mon Sep 17 00:00:00 2001 From: wolfgang Date: Thu, 7 Oct 2004 15:54:42 +0000 Subject: [PATCH] [project @ 2004-10-07 15:54:03 by wolfgang] Position Independent Code and Dynamic Linking Support, Part 1 This commit allows generation of position independent code (PIC) that fully supports dynamic linking on Mac OS X and PowerPC Linux. Other platforms are not yet supported, and there is no support for actually linking or using dynamic libraries - so if you use the -fPIC or -dynamic code generation flags, you have to type your (platform-specific) linker command lines yourself. nativeGen/PositionIndependentCode.hs: New file. Look here for some more comments on how this works. cmm/CLabel.hs: Add support for DynamicLinkerLabels and PIC base labels - for use inside the NCG. needsCDecl: Case alternative labels now need C decls, see the codeGen/CgInfoTbls.hs below for details cmm/Cmm.hs: Add CmmPicBaseReg (used in NCG), and CmmLabelDiffOff (used in NCG and for offsets in info tables) cmm/CmmParse.y: support offsets in info tables cmm/PprC.hs: support CmmLabelDiffOff Case alternative labels now need C decls (see the codeGen/CgInfoTbls.hs for details), so we need to pprDataExterns for info tables. cmm/PprCmm.hs: support CmmLabelDiffOff codeGen/CgInfoTbls.hs: no longer store absolute addresses in info tables, instead, we store offsets. Also, for vectored return points, emit the alternatives _after_ the vector table. This is to work around a limitation in Apple's as, which refuses to handle label differences where one label is at the end of a section. Emitting alternatives after vector info tables makes sure this never happens in GHC generated code. Case alternatives now require prototypes in hc code, though (see changes in PprC.hs, CLabel.hs). main/CmdLineOpts.lhs: Add a new option, -fPIC. main/DriverFlags.hs: Pass the correct options for PIC to gcc, depending on the platform. Only for powerpc for now. nativeGen/AsmCodeGen.hs: Many changes... Mac OS X-specific management of import stubs is no longer, it's now part of a general mechanism to handle such things for all platforms that need it (Darwin [both ppc and x86], Linux on ppc, and some platforms we don't support). Move cmmToCmm into its own monad which can accumulate a list of imported symbols. Make it call cmmMakeDynamicReference at the right places. nativeGen/MachCodeGen.hs: nativeGen/MachInstrs.hs: nativeGen/MachRegs.lhs: nativeGen/PprMach.hs: nativeGen/RegAllocInfo.hs: Too many changes to enumerate here, PowerPC specific. nativeGen/NCGMonad.hs: NatM still tracks imported symbols, as more labels can be created during code generation (float literals, jump tables; on some platforms all data access has to go through the dynamic linking mechanism). driver/mangler/ghc-asm.lprl: Mangle absolute addresses in info tables to offsets. Correctly pass through GCC-generated PIC for Mac OS X and powerpc linux. includes/Cmm.h: includes/InfoTables.h: includes/Storage.h: includes/mkDerivedConstants.c: rts/GC.c: rts/GCCompact.c: rts/HeapStackCheck.cmm: rts/Printer.c: rts/RetainerProfile.c: rts/Sanity.c: Adapt to the fact that info tables now contain offsets. rts/Linker.c: Mac-specific: change machoInitSymbolsWithoutUnderscore to support PIC. --- ghc/compiler/cmm/CLabel.hs | 104 ++++- ghc/compiler/cmm/Cmm.hs | 12 + ghc/compiler/cmm/CmmParse.y | 11 +- ghc/compiler/cmm/PprC.hs | 14 +- ghc/compiler/cmm/PprCmm.hs | 2 + ghc/compiler/codeGen/CgInfoTbls.hs | 78 +++- ghc/compiler/main/CmdLineOpts.lhs | 8 +- ghc/compiler/main/DriverFlags.hs | 19 +- ghc/compiler/nativeGen/AsmCodeGen.lhs | 187 +++++--- ghc/compiler/nativeGen/MachCodeGen.hs | 257 ++++++----- ghc/compiler/nativeGen/MachInstrs.hs | 4 + ghc/compiler/nativeGen/MachRegs.lhs | 10 +- ghc/compiler/nativeGen/NCGMonad.hs | 31 +- ghc/compiler/nativeGen/PositionIndependentCode.hs | 475 +++++++++++++++++++++ ghc/compiler/nativeGen/PprMach.hs | 76 ++-- ghc/compiler/nativeGen/RegAllocInfo.hs | 4 + ghc/driver/mangler/ghc-asm.lprl | 65 ++- ghc/includes/Cmm.h | 8 +- ghc/includes/InfoTables.h | 52 ++- ghc/includes/Storage.h | 2 +- ghc/includes/mkDerivedConstants.c | 2 +- ghc/rts/GC.c | 18 +- ghc/rts/GCCompact.c | 10 +- ghc/rts/HeapStackCheck.cmm | 6 + ghc/rts/Linker.c | 18 +- ghc/rts/Printer.c | 4 +- ghc/rts/RetainerProfile.c | 20 +- ghc/rts/Sanity.c | 8 +- 28 files changed, 1166 insertions(+), 339 deletions(-) create mode 100644 ghc/compiler/nativeGen/PositionIndependentCode.hs diff --git a/ghc/compiler/cmm/CLabel.hs b/ghc/compiler/cmm/CLabel.hs index c0c6e34..a2634da 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 cf76f45..9fcc96e 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 55ee5c2..7eb4bdb 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 630f6a5..a9aba40 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 961c6e4..38e7e06 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 5cda823..7692e7d 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 64ed4ad..6042f15 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 c09e43a..b3bda23 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 8f97d55..7f0bd45 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 9285518..22bd60d 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 b0b68e4..4cfcc17 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 e94086d..ec28f70 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 271828f..8fdcd44 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 0000000..d6812b1 --- /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 64ee5c6..846a855 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 da2727b..c1c259a 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 be72f7f..259d6ad 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 608e97d..0dde2c8 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 a605ba2..f3a1182 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 eb3c716..5c76094 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 f5d6213..71791fd 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 735b051..25f794f 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 0e2129f..6dd0131 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 6e8eba5..2a264b2 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 5058294..1f53d38 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 c72b33a..9e8d090 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 5cd881f..04b6583 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 d4c3dca..43e7b5a 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: -- 1.7.10.4