diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index 77792bfbd540c717f0eeea46abbd063740db93e9..17922ee4bd011c25b55c077952923b3c2fc837b4 100644
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -69,7 +69,7 @@ stmt2Instrs stmt = case stmt of
getData :: StixTree -> UniqSM (InstrBlock, Imm)
getData (StInt i) = returnUs (id, ImmInteger i)
- getData (StDouble d) = returnUs (id, dblImmLit d)
+ getData (StDouble d) = returnUs (id, ImmDouble d)
getData (StLitLbl s) = returnUs (id, ImmLab s)
getData (StCLbl l) = returnUs (id, ImmCLbl l)
getData (StString s) =
@@ -499,7 +499,7 @@ getRegister (StDouble d)
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
- DATA DF [dblImmLit d],
+ DATA DF [ImmDouble d],
SEGMENT TextSegment,
FLD DF (OpImm (ImmCLbl lbl))
]
@@ -911,7 +911,7 @@ getRegister (StDouble d)
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
- DATA DF [dblImmLit d],
+ DATA DF [ImmDouble d],
SEGMENT TextSegment,
SETHI (HI (ImmCLbl lbl)) tmp,
LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs
index bf0b939d23b0e21e66756a4946d8a9d898b0804d..f5e02cb8546eb5eefaeab49f379bdd17e698c77f 100644
--- a/ghc/compiler/nativeGen/MachRegs.lhs
+++ b/ghc/compiler/nativeGen/MachRegs.lhs
@@ -25,7 +25,6 @@ module MachRegs (
baseRegOffset,
callClobberedRegs,
callerSaves,
- dblImmLit,
extractMappedRegNos,
freeMappedRegs,
freeReg, freeRegs,
@@ -83,17 +82,12 @@ data Imm
| ImmLab SDoc -- Simple string label (underscore-able)
| ImmLit SDoc -- Simple string
| ImmIndex CLabel Int
+ | ImmDouble Rational
IF_ARCH_sparc(
| LO Imm -- Possible restrictions...
| HI Imm
,)
strImmLit s = ImmLit (text s)
-dblImmLit r
- = strImmLit (
- IF_ARCH_alpha({-prepend nothing-}
- ,IF_ARCH_i386( '0' : 'd' :
- ,IF_ARCH_sparc('0' : 'r' :,)))
- showSDoc (rational r))
\end{code}
% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs
index 3e8bde036ff9f185453d680dea3cfe1afb574ca3..a46ad7ebf82401793de65e1aa4c909f3e8bba606 100644
--- a/ghc/compiler/nativeGen/PprMach.lhs
+++ b/ghc/compiler/nativeGen/PprMach.lhs
@@ -20,9 +20,13 @@ import MachMisc
import CLabel ( pprCLabel_asm, externallyVisibleCLabel )
import CStrings ( charToC )
import Maybes ( maybeToBool )
-import Stix ( CodeSegment(..) )
+import Stix ( CodeSegment(..), StixTree(..) )
import Char ( isPrint, isDigit )
import Outputable
+
+import ST
+import MutableArray
+import Char ( ord )
\end{code}
%************************************************************************
@@ -403,10 +407,6 @@ pprInstr (SEGMENT TextSegment)
,IF_ARCH_i386((_PK_ ".text\n\t.align 4") {-needs per-OS variation!-}
,)))
-#if 0
- ,IF_ARCH_i386((_PK_ ".text\n\t.align 2\x2c\&0x90") {-needs per-OS variation!-}
-#endif
-
pprInstr (SEGMENT DataSegment)
= ptext
IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
@@ -414,10 +414,6 @@ pprInstr (SEGMENT DataSegment)
,IF_ARCH_i386(SLIT(".data\n\t.align 4")
,)))
-#if 0
- ,IF_ARCH_i386(SLIT(".data\n\t.align 2")
-#endif
-
pprInstr (LABEL clab)
= let
pp_lab = pprCLabel_asm clab
@@ -454,6 +450,7 @@ pprInstr (ASCII True str)
| isDigit d = (<>) (text (charToC c)) (asciify cs 0)
| otherwise = (<>) (text (charToC c)) (asciify cs (n-1))
+#if 0
pprInstr (DATA s xs)
= vcat [(<>) (ptext pp_size) (pprImm x) | x <- xs]
where
@@ -461,20 +458,11 @@ pprInstr (DATA s xs)
#if alpha_TARGET_ARCH
B -> SLIT("\t.byte\t")
BU -> SLIT("\t.byte\t")
---UNUSED: W -> SLIT("\t.word\t")
---UNUSED: WU -> SLIT("\t.word\t")
---UNUSED: L -> SLIT("\t.long\t")
Q -> SLIT("\t.quad\t")
---UNUSED: FF -> SLIT("\t.f_floating\t")
---UNUSED: DF -> SLIT("\t.d_floating\t")
---UNUSED: GF -> SLIT("\t.g_floating\t")
---UNUSED: SF -> SLIT("\t.s_floating\t")
TF -> SLIT("\t.t_floating\t")
#endif
#if i386_TARGET_ARCH
B -> SLIT("\t.byte\t")
---UNUSED: HB -> SLIT("\t.byte\t")
---UNUSED: S -> SLIT("\t.word\t")
L -> SLIT("\t.long\t")
F -> SLIT("\t.float\t")
DF -> SLIT("\t.double\t")
@@ -485,6 +473,65 @@ pprInstr (DATA s xs)
W -> SLIT("\t.word\t")
DF -> SLIT("\t.double\t")
#endif
+#endif
+
+
+pprInstr (DATA s xs)
+ = vcat (concatMap (ppr_item s) xs)
+ where
+#if alpha_TARGET_ARCH
+ This needs to be fixed.
+ B -> SLIT("\t.byte\t")
+ BU -> SLIT("\t.byte\t")
+ Q -> SLIT("\t.quad\t")
+ TF -> SLIT("\t.t_floating\t")
+#endif
+#if i386_TARGET_ARCH
+ ppr_item B x = [text "\t.byte\t" <> pprImm x]
+ ppr_item L x = [text "\t.long\t" <> pprImm x]
+ ppr_item F (ImmDouble r)
+ = let bs = floatToBytes (fromRational r)
+ in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+ ppr_item DF (ImmDouble r)
+ = let bs = doubleToBytes (fromRational r)
+ in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+
+ floatToBytes :: Float -> [Int]
+ floatToBytes f
+ = runST (do
+ arr <- newFloatArray ((0::Int),3)
+ writeFloatArray arr 0 f
+ i0 <- readCharArray arr 0
+ i1 <- readCharArray arr 1
+ i2 <- readCharArray arr 2
+ i3 <- readCharArray arr 3
+ return (map ord [i0,i1,i2,i3])
+ )
+
+ doubleToBytes :: Double -> [Int]
+ doubleToBytes d
+ = runST (do
+ arr <- newDoubleArray ((0::Int),7)
+ writeDoubleArray arr 0 d
+ 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])
+ )
+
+#endif
+#if sparc_TARGET_ARCH
+ This needs to be fixed.
+ B -> SLIT("\t.byte\t")
+ BU -> SLIT("\t.byte\t")
+ W -> SLIT("\t.word\t")
+ DF -> SLIT("\t.double\t")
+#endif
-- fall through to rest of (machine-specific) pprInstr...
\end{code}
diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs
index ea39abe1778c390cecfe4d55a3587d150ac472ad..5eb0362ddcc5ac15d4ebce2851b8677d7acf23e4 100644
--- a/ghc/compiler/nativeGen/Stix.lhs
+++ b/ghc/compiler/nativeGen/Stix.lhs
@@ -20,7 +20,7 @@ import Ratio ( Rational )
import AbsCSyn ( node, tagreg, MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
import CallConv ( CallConv, pprCallConv )
-import CLabel ( mkAsmTempLabel, CLabel, pprCLabel )
+import CLabel ( mkAsmTempLabel, CLabel, pprCLabel, pprCLabel_asm )
import PrimRep ( PrimRep, showPrimRep )
import PrimOp ( PrimOp, pprPrimOp )
import Unique ( Unique )