Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2009,2011-2012 Matthew Fluet. |
2 | * Copyright (C) 2004-2006 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * | |
5 | * MLton is released under a BSD-style license. | |
6 | * See the file MLton-LICENSE for details. | |
7 | *) | |
8 | ||
9 | functor RealX (S: REAL_X_STRUCTS): REAL_X = | |
10 | struct | |
11 | ||
12 | open S | |
13 | ||
14 | structure P = Pervasive | |
15 | structure PR32 = P.Real32 | |
16 | structure PR64 = P.Real64 | |
17 | structure PIR = P.IEEEReal | |
18 | ||
19 | datatype z = datatype RealSize.t | |
20 | ||
21 | datatype t = | |
22 | Real32 of Real32.t | |
23 | | Real64 of Real64.t | |
24 | ||
25 | fun zero s = | |
26 | case s of | |
27 | R32 => Real32 0.0 | |
28 | | R64 => Real64 0.0 | |
29 | ||
30 | fun size r = | |
31 | case r of | |
32 | Real32 _ => R32 | |
33 | | Real64 _ => R64 | |
34 | ||
35 | fun make (r: string, s: RealSize.t): t option = | |
36 | let | |
37 | fun doit (fromString, isFinite, con): t option = | |
38 | case fromString r of | |
39 | NONE => Error.bug "RealX.make: unexpected real constant" | |
40 | | SOME r => | |
41 | if isFinite r | |
42 | then SOME (con r) | |
43 | else NONE | |
44 | in | |
45 | case s of | |
46 | R32 => doit (Real32.fromString, Real32.isFinite, Real32) | |
47 | | R64 => doit (Real64.fromString, Real64.isFinite, Real64) | |
48 | end | |
49 | ||
50 | (* RealX.equals determines if two floating-point constants are equal. | |
51 | * Must check the sign bit, since Real{32,64}.== ignores the sign of | |
52 | * zeros; the difference between 0.0 and ~0.0 is observable by | |
53 | * programs that examine the sign bit. | |
54 | * Should check for nan, since Real{32,64}.== returns false for any | |
55 | * comparison with nan values. Ideally, should use bit-wise equality | |
56 | * since there are multiple representations for nan. However, SML/NJ | |
57 | * doesn't support the PackReal structures that would be required to | |
58 | * compare real values as bit patterns. Conservatively return | |
59 | * 'false'; constant-propagation and common-subexpression elimination | |
60 | * will not combine nan values. | |
61 | *) | |
62 | fun equals (r, r') = | |
63 | case (r, r') of | |
64 | (Real32 r, Real32 r') => | |
65 | let | |
66 | open Real32 | |
67 | in | |
68 | equals (r, r') andalso signBit r = signBit r' | |
69 | end | |
70 | | (Real64 r, Real64 r') => | |
71 | let | |
72 | open Real64 | |
73 | in | |
74 | equals (r, r') andalso signBit r = signBit r' | |
75 | end | |
76 | | _ => false | |
77 | ||
78 | fun toString r = | |
79 | case r of | |
80 | Real32 r => Real32.format (r, Real32.Format.exact) | |
81 | | Real64 r => Real64.format (r, Real64.Format.exact) | |
82 | ||
83 | val layout = Layout.str o toString | |
84 | ||
85 | val hash = String.hash o toString | |
86 | ||
87 | (* Disable constant folding when it might change the results. *) | |
88 | fun disableCF () = | |
89 | PR32.precision = PR64.precision | |
90 | orelse !Control.target <> Control.Self | |
91 | ||
92 | local | |
93 | fun make (o32, o64) arg = | |
94 | if disableCF () | |
95 | then NONE | |
96 | else SOME (case arg of | |
97 | Real32 x => Real32 (o32 x) | |
98 | | Real64 x => Real64 (o64 x)) | |
99 | in | |
100 | val neg = make (Real32.~, Real64.~) | |
101 | val abs = make (Real32.abs, Real64.abs) | |
102 | end | |
103 | ||
104 | datatype 'r r = | |
105 | R of {zero: 'r, half: 'r, one: 'r, inf: 'r, abs: 'r -> 'r, | |
106 | signBit: 'r -> bool, isNan: 'r -> bool, | |
107 | toManExp: 'r -> {exp: int, man: 'r}, | |
108 | compareReal: 'r * 'r -> PIR.real_order, | |
109 | bits: Bits.t, | |
110 | subVec: P.Word8Vector.vector * int -> P.LargeWord.word, | |
111 | update: P.Word8Array.array * int * P.LargeWord.word -> unit, | |
112 | toBytes: 'r -> P.Word8Vector.vector, | |
113 | subArr: P.Word8Array.array * int -> 'r, | |
114 | tag: 'r -> t} | |
115 | ||
116 | val r32 = | |
117 | R {zero = 0.0, half = 0.5, one = 1.0, inf = PR32.posInf, | |
118 | abs = PR32.abs, signBit = PR32.signBit, isNan = PR32.isNan, | |
119 | toManExp = PR32.toManExp, compareReal = PR32.compareReal, | |
120 | bits = Bits.inWord32, | |
121 | subVec = P.PackWord32Little.subVec, | |
122 | update = P.PackWord32Little.update, | |
123 | toBytes = P.PackReal32Little.toBytes, | |
124 | subArr = P.PackReal32Little.subArr, | |
125 | tag = Real32} | |
126 | val r64 = | |
127 | R {zero = 0.0, half = 0.5, one = 1.0, inf = PR64.posInf, | |
128 | abs = PR64.abs, signBit = PR64.signBit, isNan = PR64.isNan, | |
129 | toManExp = PR64.toManExp, compareReal = PR64.compareReal, | |
130 | bits = Bits.inWord64, | |
131 | subVec = P.PackWord64Little.subVec, | |
132 | update = P.PackWord64Little.update, | |
133 | toBytes = P.PackReal64Little.toBytes, | |
134 | subArr = P.PackReal64Little.subArr, | |
135 | tag = Real64} | |
136 | ||
137 | local | |
138 | fun doit (R {compareReal, signBit, tag, ...}) (f, arg) = | |
139 | if disableCF () | |
140 | then NONE | |
141 | else | |
142 | let | |
143 | val old = PIR.getRoundingMode () | |
144 | in | |
145 | (* According to the Basis Library specification, | |
146 | * setRoundingMode can fail (raise an exception). | |
147 | *) | |
148 | let | |
149 | val () = PIR.setRoundingMode PIR.TO_NEGINF | |
150 | val min = f arg | |
151 | val () = PIR.setRoundingMode PIR.TO_POSINF | |
152 | val max = f arg | |
153 | val () = PIR.setRoundingMode old | |
154 | in | |
155 | if (PIR.EQUAL = compareReal (min, max) | |
156 | andalso signBit min = signBit max) | |
157 | then SOME (tag min) | |
158 | else NONE | |
159 | end | |
160 | handle _ => | |
161 | (if PIR.getRoundingMode () = old | |
162 | then () | |
163 | else PIR.setRoundingMode old | |
164 | ; NONE) | |
165 | end | |
166 | ||
167 | fun make1 (o32, o64) = | |
168 | fn Real32 x => doit r32 (o32, x) | |
169 | | Real64 x => doit r64 (o64, x) | |
170 | ||
171 | fun make2 (o32, o64) = | |
172 | fn (Real32 x, Real32 y) => doit r32 (o32, (x, y)) | |
173 | | (Real64 x, Real64 y) => doit r64 (o64, (x, y)) | |
174 | | _ => Error.bug "impossible" | |
175 | ||
176 | fun make3 (o32, o64) = | |
177 | fn (Real32 x, Real32 y, Real32 z) => doit r32 (o32, (x, y, z)) | |
178 | | (Real64 x, Real64 y, Real64 z) => doit r64 (o64, (x, y, z)) | |
179 | | _ => Error.bug "impossible" | |
180 | in | |
181 | val acos = make1 (PR32.Math.acos, PR64.Math.acos) | |
182 | val asin = make1 (PR32.Math.asin, PR64.Math.asin) | |
183 | val atan = make1 (PR32.Math.atan, PR64.Math.atan) | |
184 | val atan2 = make2 (PR32.Math.atan2, PR64.Math.atan2) | |
185 | val cos = make1 (PR32.Math.cos, PR64.Math.cos) | |
186 | val exp = make1 (PR32.Math.exp, PR64.Math.exp) | |
187 | val ln = make1 (PR32.Math.ln, PR64.Math.ln) | |
188 | val log10 = make1 (PR32.Math.log10, PR64.Math.log10) | |
189 | val sin = make1 (PR32.Math.sin, PR64.Math.sin) | |
190 | val sqrt = make1 (PR32.Math.sqrt, PR64.Math.sqrt) | |
191 | val tan = make1 (PR32.Math.tan, PR64.Math.tan) | |
192 | ||
193 | val add = make2 (PR32.+, PR64.+) | |
194 | val op div = make2 (PR32./, PR64./) | |
195 | val mul = make2 (PR32.*, PR64.* ) | |
196 | val sub = make2 (PR32.-, PR64.-) | |
197 | ||
198 | val muladd = make3 (PR32.*+, PR64.*+) | |
199 | val mulsub = make3 (PR32.*-, PR64.*-) | |
200 | ||
201 | fun fromIntInf (i, s) = | |
202 | case s of | |
203 | R32 => doit r32 (Real32.fromIntInf, i) | |
204 | | R64 => doit r64 (Real64.fromIntInf, i) | |
205 | end | |
206 | ||
207 | local | |
208 | fun make (o32, o64) args = | |
209 | if disableCF () | |
210 | then NONE | |
211 | else | |
212 | SOME (case args of | |
213 | (Real32 r1, Real32 r2) => o32 (r1, r2) | |
214 | | (Real64 r1, Real64 r2) => o64 (r1, r2) | |
215 | | _ => Error.bug "impossible") | |
216 | in | |
217 | val equal = make (PR32.==, PR64.==) | |
218 | val le = make (PR32.<=, PR64.<=) | |
219 | val lt = make (PR32.<, PR64.<) | |
220 | val qequal = make (PR32.?=, PR64.?=) | |
221 | end | |
222 | ||
223 | datatype decon = | |
224 | NAN | |
225 | | ZERO of {signBit: bool} | |
226 | | ONE of {signBit: bool} | |
227 | | POW2 of {signBit: bool, exp: Int.t} (* man = 0.5 *) | |
228 | | FIN of {signBit: bool, exp: Int.t, man: t} | |
229 | | INF of {signBit: bool} | |
230 | ||
231 | local | |
232 | fun doit (R {zero, half, one, inf, abs, signBit, isNan, toManExp, | |
233 | compareReal, tag, ...}) | |
234 | value = | |
235 | if isNan value | |
236 | then NAN | |
237 | else let | |
238 | val signBit = signBit value | |
239 | val absValue = abs value | |
240 | in | |
241 | if PIR.EQUAL = compareReal (zero, absValue) | |
242 | then ZERO {signBit = signBit} | |
243 | else if PIR.EQUAL = compareReal (one, absValue) | |
244 | then ONE {signBit = signBit} | |
245 | else if PIR.EQUAL = compareReal (inf, absValue) | |
246 | then INF {signBit = signBit} | |
247 | else let | |
248 | val {man, exp} = toManExp absValue | |
249 | in | |
250 | if PIR.EQUAL = compareReal (half, man) | |
251 | then POW2 {signBit = signBit, exp = exp} | |
252 | else FIN {signBit = signBit, exp = exp, man = tag man} | |
253 | end | |
254 | end | |
255 | in | |
256 | fun decon x = | |
257 | if disableCF () | |
258 | then NONE | |
259 | else SOME (case x of | |
260 | Real32 x => doit r32 x | |
261 | | Real64 x => doit r64 x) | |
262 | end | |
263 | ||
264 | local | |
265 | fun doit (R {bits, toBytes, subVec, ...}) x = let | |
266 | in | |
267 | (SOME o WordX.fromIntInf) | |
268 | (P.LargeWord.toLargeInt (subVec (toBytes x, 0)), | |
269 | WordX.WordSize.fromBits bits) | |
270 | end handle _ => NONE | |
271 | in | |
272 | fun castToWord x = | |
273 | if disableCF () | |
274 | then NONE | |
275 | else | |
276 | (case x of | |
277 | Real32 x => doit r32 x | |
278 | | Real64 x => doit r64 x) | |
279 | end | |
280 | ||
281 | local | |
282 | fun doit (R {bits, update, subArr, tag, isNan, ...}) w = let | |
283 | val a = P.Word8Array.array (Bytes.toInt (Bits.toBytes bits), 0w0) | |
284 | val () = update (a, 0, P.LargeWord.fromLargeInt (WordX.toIntInf w)) | |
285 | val r = subArr (a, 0) | |
286 | in | |
287 | if isNan r | |
288 | then NONE | |
289 | else SOME (tag r) | |
290 | end handle _ => NONE | |
291 | in | |
292 | fun castFromWord w = | |
293 | if disableCF () then | |
294 | NONE | |
295 | else if WordX.WordSize.bits (WordX.size w) = Bits.inWord32 then | |
296 | doit r32 w | |
297 | else if WordX.WordSize.bits (WordX.size w) = Bits.inWord64 then | |
298 | doit r64 w | |
299 | else | |
300 | Error.bug "Invalid word size" | |
301 | end | |
302 | ||
303 | end |