-- (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
import Pretty
import FastString
import qualified Outputable
+import Outputable ( Outputable )
import Data.Array.ST
import Data.Word ( Word8 )
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"))
,)))))
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
-- 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 =
| otherwise =
[ptext SLIT("\t.quad\t") <> pprImm imm]
where
- isRelativeReloc (CmmLabelOff _ _) = True
isRelativeReloc (CmmLabelDiffOff _ _ _) = True
isRelativeReloc _ = False
#endif
-- -----------------------------------------------------------------------------
-- pprInstr: print an 'Instr'
+instance Outputable Instr where
+ ppr instr = Outputable.docToSDoc $ pprInstr instr
+
pprInstr :: Instr -> Doc
--pprInstr (COMMENT s) = empty -- nuke 'em
#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"),
#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
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
-- 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
-- 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"),
-- -----------------------------------------------------------------------------
-- Converting floating-point literals to integrals for printing
-#if __GLASGOW_HASKELL__ >= 504
-newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
-newFloatArray = newArray_
-
-newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
-newDoubleArray = newArray_
-
-castFloatToCharArray :: STUArray s Int Float -> ST s (STUArray s Int Word8)
-castFloatToCharArray = castSTUArray
+castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)
+castFloatToWord8Array = 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
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])
)
projects / ghc-hetmet.git / blobdiff