Fix #4867, ghci displays negative floats incorrectly
[ghc.git] / rts / StgPrimFloat.c
1 /* -----------------------------------------------------------------------------
2 *
3 * (c) Lennart Augustsson
4 * (c) The GHC Team, 1998-2000
5 *
6 * Miscellaneous support for floating-point primitives
7 *
8 * ---------------------------------------------------------------------------*/
9
10 #include "PosixSource.h"
11 #include "Rts.h"
12
13 #include "StgPrimFloat.h"
14
15 #include <math.h>
16 #include <float.h>
17
18 #define IEEE_FLOATING_POINT 1
19
20 /*
21 * Encoding and decoding Doubles. Code based on the HBC code
22 * (lib/fltcode.c).
23 */
24
25 #if IEEE_FLOATING_POINT
26 #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
27 /* DMINEXP is defined in values.h on Linux (for example) */
28 #define DHIGHBIT 0x00100000
29 #define DMSBIT 0x80000000
30
31 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
32 #define FHIGHBIT 0x00800000
33 #define FMSBIT 0x80000000
34 #endif
35
36 #if defined(WORDS_BIGENDIAN) || defined(FLOAT_WORDS_BIGENDIAN)
37 #define L 1
38 #define H 0
39 #else
40 #define L 0
41 #define H 1
42 #endif
43
44 #define __abs(a) (( (a) >= 0 ) ? (a) : (-(a)))
45
46 StgDouble
47 __2Int_encodeDouble (I_ j_high, I_ j_low, I_ e)
48 {
49 StgDouble r;
50
51 /* assuming 32 bit ints */
52 ASSERT(sizeof(int ) == 4 );
53
54 r = (StgDouble)((unsigned int)j_high);
55 r *= 4294967296.0; /* exp2f(32); */
56 r += (StgDouble)((unsigned int)j_low);
57
58 /* Now raise to the exponent */
59 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
60 r = ldexp(r, e);
61
62 /* sign is encoded in the size */
63 if (j_high < 0)
64 r = -r;
65
66 return r;
67 }
68
69 /* Special version for words */
70 StgDouble
71 __word_encodeDouble (W_ j, I_ e)
72 {
73 StgDouble r;
74
75 r = (StgDouble)j;
76
77 /* Now raise to the exponent */
78 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
79 r = ldexp(r, e);
80
81 return r;
82 }
83
84 /* Special version for small Integers */
85 StgDouble
86 __int_encodeDouble (I_ j, I_ e)
87 {
88 StgDouble r;
89
90 r = (StgDouble)__abs(j);
91
92 /* Now raise to the exponent */
93 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
94 r = ldexp(r, e);
95
96 /* sign is encoded in the size */
97 if (j < 0)
98 r = -r;
99
100 return r;
101 }
102
103 /* Special version for small Integers */
104 StgFloat
105 __int_encodeFloat (I_ j, I_ e)
106 {
107 StgFloat r;
108
109 r = (StgFloat)__abs(j);
110
111 /* Now raise to the exponent */
112 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
113 r = ldexp(r, e);
114
115 /* sign is encoded in the size */
116 if (j < 0)
117 r = -r;
118
119 return r;
120 }
121
122 /* Special version for small positive Integers */
123 StgFloat
124 __word_encodeFloat (W_ j, I_ e)
125 {
126 StgFloat r;
127
128 r = (StgFloat)j;
129
130 /* Now raise to the exponent */
131 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
132 r = ldexp(r, e);
133
134 return r;
135 }
136
137 /* This only supports IEEE floating point */
138
139 void
140 __decodeDouble_2Int (I_ *man_sign, W_ *man_high, W_ *man_low, I_ *exp, StgDouble dbl)
141 {
142 /* Do some bit fiddling on IEEE */
143 unsigned int low, high; /* assuming 32 bit ints */
144 int sign, iexp;
145 union { double d; unsigned int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
146
147 ASSERT(sizeof(unsigned int ) == 4 );
148 ASSERT(sizeof(dbl ) == 8 );
149 ASSERT(sizeof(dbl ) == SIZEOF_DOUBLE);
150
151 u.d = dbl; /* grab chunks of the double */
152 low = u.i[L];
153 high = u.i[H];
154
155 if (low == 0 && (high & ~DMSBIT) == 0) {
156 *man_low = 0;
157 *man_high = 0;
158 *exp = 0L;
159 } else {
160 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
161 sign = high;
162
163 high &= DHIGHBIT-1;
164 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
165 high |= DHIGHBIT;
166 else {
167 iexp++;
168 /* A denorm, normalize the mantissa */
169 while (! (high & DHIGHBIT)) {
170 high <<= 1;
171 if (low & DMSBIT)
172 high++;
173 low <<= 1;
174 iexp--;
175 }
176 }
177 *exp = (I_) iexp;
178 *man_low = low;
179 *man_high = high;
180 *man_sign = (sign < 0) ? -1 : 1;
181 }
182 }
183
184 /* Convenient union types for checking the layout of IEEE 754 types -
185 based on defs in GNU libc <ieee754.h>
186 */
187
188 void
189 __decodeFloat_Int (I_ *man, I_ *exp, StgFloat flt)
190 {
191 /* Do some bit fiddling on IEEE */
192 int high, sign; /* assuming 32 bit ints */
193 union { float f; int i; } u; /* assuming 32 bit float and int */
194
195 ASSERT(sizeof(int ) == 4 );
196 ASSERT(sizeof(flt ) == 4 );
197 ASSERT(sizeof(flt ) == SIZEOF_FLOAT );
198
199 u.f = flt; /* grab the float */
200 high = u.i;
201
202 if ((high & ~FMSBIT) == 0) {
203 *man = 0;
204 *exp = 0;
205 } else {
206 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
207 sign = high;
208
209 high &= FHIGHBIT-1;
210 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
211 high |= FHIGHBIT;
212 else {
213 (*exp)++;
214 /* A denorm, normalize the mantissa */
215 while (! (high & FHIGHBIT)) {
216 high <<= 1;
217 (*exp)--;
218 }
219 }
220 *man = high;
221 if (sign < 0)
222 *man = - *man;
223 }
224 }
225