diff options
Diffstat (limited to 'compiler/nativeGen/X86/Ppr.hs')
| -rw-r--r-- | compiler/nativeGen/X86/Ppr.hs | 149 |
1 files changed, 126 insertions, 23 deletions
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index fce432a3dc..03d4fce794 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -23,6 +23,8 @@ where #include "HsVersions.h" #include "nativeGen/NCG.h" +import GhcPrelude + import X86.Regs import X86.Instr import X86.Cond @@ -37,8 +39,9 @@ import Hoopl.Label import BasicTypes (Alignment) import DynFlags import Cmm hiding (topInfoTable) +import BlockId import CLabel -import Unique ( pprUniqueAlways, Uniquable(..) ) +import Unique ( pprUniqueAlways ) import Platform import FastString import Outputable @@ -70,12 +73,17 @@ import Data.Bits -- .subsections_via_symbols and -dead_strip can be found at -- <https://developer.apple.com/library/mac/documentation/DeveloperTools/Reference/Assembler/040-Assembler_Directives/asm_directives.html#//apple_ref/doc/uid/TP30000823-TPXREF101> +pprProcAlignment :: SDoc +pprProcAlignment = sdocWithDynFlags $ \dflags -> + (maybe empty pprAlign . cmmProcAlignment $ dflags) + pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc pprNatCmmDecl (CmmData section dats) = pprSectionAlign section $$ pprDatas dats pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = sdocWithDynFlags $ \dflags -> + pprProcAlignment $$ case topInfoTable proc of Nothing -> case blocks of @@ -83,6 +91,7 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = pprLabel lbl blocks -> -- special case for code without info table: pprSectionAlign (Section Text lbl) $$ + pprProcAlignment $$ pprLabel lbl $$ -- blocks guaranteed not null, so label needed vcat (map (pprBasicBlock top_info) blocks) $$ (if debugLevel dflags > 0 @@ -92,6 +101,7 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = Just (Statics info_lbl _) -> sdocWithPlatform $ \platform -> pprSectionAlign (Section Text info_lbl) $$ + pprProcAlignment $$ (if platformHasSubsectionsViaSymbols platform then ppr (mkDeadStripPreventer info_lbl) <> char ':' else empty) $$ @@ -126,7 +136,7 @@ pprBasicBlock info_env (BasicBlock blockid instrs) (if debugLevel dflags > 0 then ppr (mkAsmTempEndLabel asmLbl) <> char ':' else empty) where - asmLbl = mkAsmTempLabel (getUnique blockid) + asmLbl = blockLbl blockid maybe_infotable = case mapLookup blockid info_env of Nothing -> empty Just (Statics info_lbl info) -> @@ -160,35 +170,116 @@ pprGloblDecl lbl | not (externallyVisibleCLabel lbl) = empty | otherwise = text ".globl " <> ppr lbl -pprTypeAndSizeDecl :: CLabel -> SDoc -pprTypeAndSizeDecl lbl +pprLabelType' :: DynFlags -> CLabel -> SDoc +pprLabelType' dflags lbl = + if isCFunctionLabel lbl || functionOkInfoTable then + text "@function" + else + text "@object" + where + {- + NOTE: This is a bit hacky. + + With the `tablesNextToCode` info tables look like this: + ``` + <info table data> + label_info: + <info table code> + ``` + So actually info table label points exactly to the code and we can mark + the label as @function. (This is required to make perf and potentially other + tools to work on Haskell binaries). + This usually works well but it can cause issues with a linker. + A linker uses different algorithms for the relocation depending on + the symbol type.For some reason, a linker will generate JUMP_SLOT relocation + when constructor info table is referenced from a data section. + This only happens with static constructor call so + we mark _con_info symbols as `@object` to avoid the issue with relocations. + + @SimonMarlow hack explanation: + "The reasoning goes like this: + + * The danger when we mark a symbol as `@function` is that the linker will + redirect it to point to the PLT and use a `JUMP_SLOT` relocation when + the symbol refers to something outside the current shared object. + A PLT / JUMP_SLOT reference only works for symbols that we jump to, not + for symbols representing data,, nor for info table symbol references which + we expect to point directly to the info table. + * GHC generates code that might refer to any info table symbol from the text + segment, but that's OK, because those will be explicit GOT references + generated by the code generator. + * When we refer to info tables from the data segment, it's either + * a FUN_STATIC/THUNK_STATIC local to this module + * a `con_info` that could be from anywhere + + So, the only info table symbols that we might refer to from the data segment + of another shared object are `con_info` symbols, so those are the ones we + need to exclude from getting the @function treatment. + " + + A good place to check for more + https://ghc.haskell.org/trac/ghc/wiki/Commentary/PositionIndependentCode + + Another possible hack is to create an extra local function symbol for + every code-like thing to give the needed information for to the tools + but mess up with the relocation. https://phabricator.haskell.org/D4730 + -} + functionOkInfoTable = tablesNextToCode dflags && + isInfoTableLabel lbl && not (isConInfoTableLabel lbl) + + +pprTypeDecl :: CLabel -> SDoc +pprTypeDecl lbl = sdocWithPlatform $ \platform -> if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl - then text ".type " <> ppr lbl <> ptext (sLit ", @object") + then + sdocWithDynFlags $ \df -> + text ".type " <> ppr lbl <> ptext (sLit ", ") <> pprLabelType' df lbl else empty pprLabel :: CLabel -> SDoc pprLabel lbl = pprGloblDecl lbl - $$ pprTypeAndSizeDecl lbl + $$ pprTypeDecl lbl $$ (ppr lbl <> char ':') +{- +Note [Pretty print ASCII when AsmCodeGen] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Previously, when generating assembly code, we created SDoc with +`(ptext . sLit)` for every bytes in literal bytestring, then +combine them using `hcat`. + +When handling literal bytestrings with millions of bytes, +millions of SDoc would be created and to combine, leading to +high memory usage. + +Now we escape the given bytestring to string directly and construct +SDoc only once. This improvement could dramatically decrease the +memory allocation from 4.7GB to 1.3GB when embedding a 3MB literal +string in source code. See Trac #14741 for profiling results. +-} pprASCII :: [Word8] -> SDoc pprASCII str - = hcat (map (do1 . fromIntegral) str) + -- Transform this given literal bytestring to escaped string and construct + -- the literal SDoc directly. + -- See Trac #14741 + -- and Note [Pretty print ASCII when AsmCodeGen] + = ptext $ sLit $ foldr (\w s -> (do1 . fromIntegral) w ++ s) "" str where - do1 :: Int -> SDoc - do1 w | '\t' <- chr w = ptext (sLit "\\t") - do1 w | '\n' <- chr w = ptext (sLit "\\n") - do1 w | '"' <- chr w = ptext (sLit "\\\"") - do1 w | '\\' <- chr w = ptext (sLit "\\\\") - do1 w | isPrint (chr w) = char (chr w) - do1 w | otherwise = char '\\' <> octal w - - octal :: Int -> SDoc - octal w = int ((w `div` 64) `mod` 8) - <> int ((w `div` 8) `mod` 8) - <> int (w `mod` 8) + do1 :: Int -> String + do1 w | '\t' <- chr w = "\\t" + | '\n' <- chr w = "\\n" + | '"' <- chr w = "\\\"" + | '\\' <- chr w = "\\\\" + | isPrint (chr w) = [chr w] + | otherwise = '\\' : octal w + + octal :: Int -> String + octal w = [ chr (ord '0' + (w `div` 64) `mod` 8) + , chr (ord '0' + (w `div` 8) `mod` 8) + , chr (ord '0' + w `mod` 8) + ] pprAlign :: Int -> SDoc pprAlign bytes @@ -505,7 +596,7 @@ pprDataItem' dflags lit -- case lit of -- A relative relocation: - CmmLabelDiffOff _ _ _ -> + CmmLabelDiffOff _ _ _ _ -> [text "\t.long\t" <> pprImm imm, text "\t.long\t0"] _ -> @@ -516,7 +607,7 @@ pprDataItem' dflags lit asmComment :: SDoc -> SDoc -asmComment c = ifPprDebug $ text "# " <> c +asmComment c = whenPprDebug $ text "# " <> c pprInstr :: Instr -> SDoc @@ -645,6 +736,9 @@ pprInstr (POPCNT format src dst) = pprOpOp (sLit "popcnt") format src (OpReg dst pprInstr (BSF format src dst) = pprOpOp (sLit "bsf") format src (OpReg dst) pprInstr (BSR format src dst) = pprOpOp (sLit "bsr") format src (OpReg dst) +pprInstr (PDEP format src mask dst) = pprFormatOpOpReg (sLit "pdep") format src mask dst +pprInstr (PEXT format src mask dst) = pprFormatOpOpReg (sLit "pext") format src mask dst + pprInstr (PREFETCH NTA format src ) = pprFormatOp_ (sLit "prefetchnta") format src pprInstr (PREFETCH Lvl0 format src) = pprFormatOp_ (sLit "prefetcht0") format src pprInstr (PREFETCH Lvl1 format src) = pprFormatOp_ (sLit "prefetcht1") format src @@ -702,7 +796,7 @@ pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op) pprInstr (JXX cond blockid) = pprCondInstr (sLit "j") cond (ppr lab) - where lab = mkAsmTempLabel (getUnique blockid) + where lab = blockLbl blockid pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm) @@ -1259,6 +1353,16 @@ pprFormatRegRegReg name format reg1 reg2 reg3 pprReg format reg3 ] +pprFormatOpOpReg :: LitString -> Format -> Operand -> Operand -> Reg -> SDoc +pprFormatOpOpReg name format op1 op2 reg3 + = hcat [ + pprMnemonic name format, + pprOperand format op1, + comma, + pprOperand format op2, + comma, + pprReg format reg3 + ] pprFormatAddrReg :: LitString -> Format -> AddrMode -> Reg -> SDoc pprFormatAddrReg name format op dst @@ -1302,4 +1406,3 @@ pprFormatOpOpCoerce name format1 format2 op1 op2 pprCondInstr :: LitString -> Cond -> SDoc -> SDoc pprCondInstr name cond arg = hcat [ char '\t', ptext name, pprCond cond, space, arg] - |