X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FPprMach.hs;h=1f94e5fd73ca98583fbd03b406f77b3373c4e002;hp=f1e02400fe0438ef3c32f5982955ae51359ca05b;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hpb=28c556a5e0ed5c2687f19ec6ef8853b79ad65518 diff --git a/compiler/nativeGen/PprMach.hs b/compiler/nativeGen/PprMach.hs index f1e0240..1f94e5f 100644 --- a/compiler/nativeGen/PprMach.hs +++ b/compiler/nativeGen/PprMach.hs @@ -10,11 +10,18 @@ -- (e.g., 'pprReg'); we conclude with the no-commonality monster, -- 'pprInstr'. +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + #include "nativeGen/NCG.h" module PprMach ( - pprNatCmmTop, pprBasicBlock, - pprInstr, pprSize, pprUserReg, + pprNatCmmTop, pprBasicBlock, pprSectionHeader, pprData, + pprInstr, pprSize, pprUserReg ) where @@ -36,6 +43,7 @@ import Unique ( pprUnique ) import Pretty import FastString import qualified Outputable +import Outputable ( Outputable ) import Data.Array.ST import Data.Word ( Word8 ) @@ -646,9 +654,9 @@ pprSectionHeader RelocatableReadOnlyData IF_ARCH_alpha(SLIT("\t.data\n\t.align 3") ,IF_ARCH_sparc(SLIT(".data\n\t.align 8") {-<8 will break double constants -} ,IF_ARCH_i386(IF_OS_darwin(SLIT(".const_data\n.align 2"), - SLIT(".section .rodata\n\t.align 4")) + SLIT(".section .data\n\t.align 4")) ,IF_ARCH_x86_64(IF_OS_darwin(SLIT(".const_data\n.align 3"), - SLIT(".section .rodata\n\t.align 8")) + SLIT(".section .data\n\t.align 8")) ,IF_ARCH_powerpc(IF_OS_darwin(SLIT(".const_data\n.align 2"), SLIT(".data\n\t.align 2")) ,))))) @@ -692,8 +700,18 @@ pprGloblDecl lbl SLIT(".globl ")) <> pprCLabel_asm lbl +pprTypeAndSizeDecl :: CLabel -> Doc +pprTypeAndSizeDecl lbl +#if linux_TARGET_OS + | not (externallyVisibleCLabel lbl) = empty + | otherwise = ptext SLIT(".type ") <> + pprCLabel_asm lbl <> ptext SLIT(", @object") +#else + = empty +#endif + pprLabel :: CLabel -> Doc -pprLabel lbl = pprGloblDecl lbl $$ (pprCLabel_asm lbl <> char ':') +pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':') pprASCII str @@ -760,7 +778,8 @@ pprDataItem lit -- Fortunately we're assuming the small memory model, in which -- all such offsets will fit into 32 bits, so we have to stick -- to 32-bit offset fields and modify the RTS appropriately - -- (see InfoTables.h). + -- + -- See Note [x86-64-relative] in includes/InfoTables.h -- ppr_item I64 x | isRelativeReloc x = @@ -769,7 +788,6 @@ pprDataItem lit | otherwise = [ptext SLIT("\t.quad\t") <> pprImm imm] where - isRelativeReloc (CmmLabelOff _ _) = True isRelativeReloc (CmmLabelDiffOff _ _ _) = True isRelativeReloc _ = False #endif @@ -788,6 +806,9 @@ pprDataItem lit -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' +instance Outputable Instr where + ppr instr = Outputable.docToSDoc $ pprInstr instr + pprInstr :: Instr -> Doc --pprInstr (COMMENT s) = empty -- nuke 'em @@ -815,6 +836,22 @@ pprInstr (LDATA _ _) #if alpha_TARGET_ARCH +pprInstr (SPILL reg slot) + = hcat [ + ptext SLIT("\tSPILL"), + char '\t', + pprReg reg, + comma, + ptext SLIT("SLOT") <> parens (int slot)] + +pprInstr (RELOAD slot reg) + = hcat [ + ptext SLIT("\tRELOAD"), + char '\t', + ptext SLIT("SLOT") <> parens (int slot), + comma, + pprReg reg] + pprInstr (LD size reg addr) = hcat [ ptext SLIT("\tld"), @@ -1197,14 +1234,21 @@ pprSizeRegRegReg name size reg1 reg2 reg3 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH -pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack - | src == dst - = -#if 0 /* #ifdef DEBUG */ - (<>) (ptext SLIT("# warning: ")) (pprSizeOpOp SLIT("mov") size s d) -#else - empty -#endif +pprInstr (SPILL reg slot) + = hcat [ + ptext SLIT("\tSPILL"), + char ' ', + pprUserReg reg, + comma, + ptext SLIT("SLOT") <> parens (int slot)] + +pprInstr (RELOAD slot reg) + = hcat [ + ptext SLIT("\tRELOAD"), + char ' ', + ptext SLIT("SLOT") <> parens (int slot), + comma, + pprUserReg reg] pprInstr (MOV size src dst) = pprSizeOpOp SLIT("mov") size src dst @@ -1291,6 +1335,8 @@ pprInstr (JXX cond (BlockId id)) = pprCondInstr SLIT("j") cond (pprCLabel_asm lab) where lab = mkAsmTempLabel id +pprInstr (JXX_GBL cond imm) = pprCondInstr SLIT("j") cond (pprImm imm) + pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm) pprInstr (JMP op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand wordRep op) pprInstr (JMP_TBL op ids) = pprInstr (JMP op) @@ -1306,12 +1352,12 @@ pprInstr (MUL size op1 op2) = pprSizeOpOp SLIT("mul") size op1 op2 pprInstr (FDIV size op1 op2) = pprSizeOpOp SLIT("div") size op1 op2 -pprInstr (CVTSS2SD from to) = pprRegReg SLIT("cvtss2sd") from to -pprInstr (CVTSD2SS from to) = pprRegReg SLIT("cvtsd2ss") from to -pprInstr (CVTSS2SI from to) = pprOpReg SLIT("cvtss2siq") from to -pprInstr (CVTSD2SI from to) = pprOpReg SLIT("cvtsd2siq") from to -pprInstr (CVTSI2SS from to) = pprOpReg SLIT("cvtsi2ssq") from to -pprInstr (CVTSI2SD from to) = pprOpReg SLIT("cvtsi2sdq") from to +pprInstr (CVTSS2SD from to) = pprRegReg SLIT("cvtss2sd") from to +pprInstr (CVTSD2SS from to) = pprRegReg SLIT("cvtsd2ss") from to +pprInstr (CVTTSS2SIQ from to) = pprOpReg SLIT("cvttss2siq") from to +pprInstr (CVTTSD2SIQ from to) = pprOpReg SLIT("cvttsd2siq") from to +pprInstr (CVTSI2SS from to) = pprOpReg SLIT("cvtsi2ssq") from to +pprInstr (CVTSI2SD from to) = pprOpReg SLIT("cvtsi2sdq") from to #endif -- FETCHGOT for PIC on ELF platforms @@ -1765,6 +1811,22 @@ pprCondInstr name cond arg -- reads (bytearrays). -- +pprInstr (SPILL reg slot) + = hcat [ + ptext SLIT("\tSPILL"), + char '\t', + pprReg reg, + comma, + ptext SLIT("SLOT") <> parens (int slot)] + +pprInstr (RELOAD slot reg) + = hcat [ + ptext SLIT("\tRELOAD"), + char '\t', + ptext SLIT("SLOT") <> parens (int slot), + comma, + pprReg reg] + -- Translate to the following: -- add g1,g2,g1 -- ld [g1],%fn @@ -2039,6 +2101,23 @@ pp_comma_a = text ",a" -- pprInstr for PowerPC #if powerpc_TARGET_ARCH + +pprInstr (SPILL reg slot) + = hcat [ + ptext SLIT("\tSPILL"), + char '\t', + pprReg reg, + comma, + ptext SLIT("SLOT") <> parens (int slot)] + +pprInstr (RELOAD slot reg) + = hcat [ + ptext SLIT("\tRELOAD"), + char '\t', + ptext SLIT("SLOT") <> parens (int slot), + comma, + pprReg reg] + pprInstr (LD sz reg addr) = hcat [ char '\t', ptext SLIT("l"), @@ -2162,6 +2241,19 @@ pprInstr (BCC cond (BlockId id)) = hcat [ ] where lbl = mkAsmTempLabel id +pprInstr (BCCFAR cond (BlockId id)) = vcat [ + hcat [ + ptext SLIT("\tb"), + pprCond (condNegate cond), + ptext SLIT("\t$+8") + ], + hcat [ + ptext SLIT("\tb\t"), + pprCLabel_asm lbl + ] + ] + where lbl = mkAsmTempLabel id + pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel char '\t', ptext SLIT("b"), @@ -2322,6 +2414,8 @@ pprInstr (FETCHPC reg) = vcat [ hcat [ ptext SLIT("1:\tmflr\t"), pprReg reg ] ] +pprInstr LWSYNC = ptext SLIT("\tlwsync") + pprInstr _ = panic "pprInstr (ppc)" pprLogic op reg1 reg2 ri = hcat [ @@ -2378,41 +2472,11 @@ limitShiftRI x = x -- ----------------------------------------------------------------------------- -- Converting floating-point literals to integrals for printing -#if __GLASGOW_HASKELL__ >= 504 -newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float) -newFloatArray = newArray_ +castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8) +castFloatToWord8Array = castSTUArray -newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double) -newDoubleArray = newArray_ - -castFloatToCharArray :: STUArray s Int Float -> ST s (STUArray s Int Word8) -castFloatToCharArray = castSTUArray - -castDoubleToCharArray :: STUArray s Int Double -> ST s (STUArray s Int Word8) -castDoubleToCharArray = castSTUArray - -writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s () -writeFloatArray = writeArray - -writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s () -writeDoubleArray = writeArray - -readCharArray :: STUArray s Int Word8 -> Int -> ST s Char -readCharArray arr i = do - w <- readArray arr i - return $! (chr (fromIntegral w)) - -#else - -castFloatToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t) -castFloatToCharArray = return - -castDoubleToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t) - - -castDoubleToCharArray = return - -#endif +castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8) +castDoubleToWord8Array = castSTUArray -- floatToBytes and doubleToBytes convert to the host's byte -- order. Providing that we're not cross-compiling for a @@ -2425,29 +2489,29 @@ castDoubleToCharArray = return floatToBytes :: Float -> [Int] floatToBytes f = runST (do - arr <- newFloatArray ((0::Int),3) - writeFloatArray arr 0 f - arr <- castFloatToCharArray arr - i0 <- readCharArray arr 0 - i1 <- readCharArray arr 1 - i2 <- readCharArray arr 2 - i3 <- readCharArray arr 3 - return (map ord [i0,i1,i2,i3]) + arr <- newArray_ ((0::Int),3) + writeArray arr 0 f + arr <- castFloatToWord8Array arr + i0 <- readArray arr 0 + i1 <- readArray arr 1 + i2 <- readArray arr 2 + i3 <- readArray arr 3 + return (map fromIntegral [i0,i1,i2,i3]) ) doubleToBytes :: Double -> [Int] doubleToBytes d = runST (do - arr <- newDoubleArray ((0::Int),7) - writeDoubleArray arr 0 d - arr <- castDoubleToCharArray arr - i0 <- readCharArray arr 0 - i1 <- readCharArray arr 1 - i2 <- readCharArray arr 2 - i3 <- readCharArray arr 3 - i4 <- readCharArray arr 4 - i5 <- readCharArray arr 5 - i6 <- readCharArray arr 6 - i7 <- readCharArray arr 7 - return (map ord [i0,i1,i2,i3,i4,i5,i6,i7]) + arr <- newArray_ ((0::Int),7) + writeArray arr 0 d + arr <- castDoubleToWord8Array arr + i0 <- readArray arr 0 + i1 <- readArray arr 1 + i2 <- readArray arr 2 + i3 <- readArray arr 3 + i4 <- readArray arr 4 + i5 <- readArray arr 5 + i6 <- readArray arr 6 + i7 <- readArray arr 7 + return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7]) )