Fix conversions between Float/Double and simple-integer
[ghc.git] / libraries / integer-simple / GHC / Integer.hs
1
2 {-# LANGUAGE NoImplicitPrelude, BangPatterns #-}
3
4 -----------------------------------------------------------------------------
5 -- |
6 -- Module : GHC.Integer
7 -- Copyright : (c) Ian Lnyagh 2007-2008
8 -- License : BSD3
9 --
10 -- Maintainer : igloo@earth.li
11 -- Stability : internal
12 -- Portability : non-portable (GHC Extensions)
13 --
14 -- An simple definition of the 'Integer' type.
15 --
16 -----------------------------------------------------------------------------
17
18 #include "MachDeps.h"
19
20 module GHC.Integer (
21 Integer,
22 smallInteger, wordToInteger, integerToWord, toInt#,
23 #if WORD_SIZE_IN_BITS < 64
24 integerToWord64, word64ToInteger,
25 integerToInt64, int64ToInteger,
26 #endif
27 plusInteger, minusInteger, timesInteger, negateInteger,
28 eqInteger, neqInteger, absInteger, signumInteger,
29 leInteger, gtInteger, ltInteger, geInteger, compareInteger,
30 divModInteger, quotRemInteger, quotInteger, remInteger,
31 encodeFloatInteger, decodeFloatInteger, floatFromInteger,
32 encodeDoubleInteger, decodeDoubleInteger, doubleFromInteger,
33 -- gcdInteger, lcmInteger, -- XXX
34 andInteger, orInteger, xorInteger, complementInteger,
35 hashInteger,
36 ) where
37
38 import GHC.Bool
39 import GHC.Ordering
40 import GHC.Prim
41 #if WORD_SIZE_IN_BITS < 64
42 import GHC.IntWord64
43 #endif
44
45 #if !defined(__HADDOCK__)
46
47 errorInteger :: Integer
48 errorInteger = Positive errorPositive
49
50 errorPositive :: Positive
51 errorPositive = Some 47## None -- Random number
52
53 data Integer = Positive !Positive | Negative !Positive | Naught
54
55 smallInteger :: Int# -> Integer
56 smallInteger i = if i >=# 0# then wordToInteger (int2Word# i)
57 else -- XXX is this right for -minBound?
58 negateInteger (wordToInteger (int2Word# (negateInt# i)))
59
60 wordToInteger :: Word# -> Integer
61 wordToInteger w = if w `eqWord#` 0##
62 then Naught
63 else Positive (Some w None)
64
65 integerToWord :: Integer -> Word#
66 integerToWord (Positive (Some w _)) = w
67 integerToWord (Negative (Some w _)) = 0## `minusWord#` w
68 -- Must be Naught by the invariant:
69 integerToWord _ = 0##
70
71 toInt# :: Integer -> Int#
72 toInt# i = word2Int# (integerToWord i)
73
74 #if WORD_SIZE_IN_BITS == 64
75 -- Nothing
76 #elif WORD_SIZE_IN_BITS == 32
77 integerToWord64 :: Integer -> Word64#
78 integerToWord64 i = int64ToWord64# (integerToInt64 i)
79
80 word64ToInteger:: Word64# -> Integer
81 word64ToInteger w = if w `eqWord64#` wordToWord64# 0##
82 then Naught
83 else Positive (word64ToPositive w)
84
85 integerToInt64 :: Integer -> Int64#
86 integerToInt64 Naught = intToInt64# 0#
87 integerToInt64 (Positive p) = word64ToInt64# (positiveToWord64 p)
88 integerToInt64 (Negative p)
89 = negateInt64# (word64ToInt64# (positiveToWord64 p))
90
91 int64ToInteger :: Int64# -> Integer
92 int64ToInteger i
93 = if i `eqInt64#` intToInt64# 0#
94 then Naught
95 else if i `gtInt64#` intToInt64# 0#
96 then Positive (word64ToPositive (int64ToWord64# i))
97 else Negative (word64ToPositive (int64ToWord64# (negateInt64# i)))
98 #else
99 #error WORD_SIZE_IN_BITS not supported
100 #endif
101
102 oneInteger :: Integer
103 oneInteger = Positive onePositive
104
105 negativeOneInteger :: Integer
106 negativeOneInteger = Negative onePositive
107
108 twoToTheThirtytwoInteger :: Integer
109 twoToTheThirtytwoInteger = Positive twoToTheThirtytwoPositive
110
111 encodeDoubleInteger :: Integer -> Int# -> Double#
112 encodeDoubleInteger (Positive ds0) e0 = f 0.0## ds0 e0
113 where f !acc None (!_) = acc
114 f !acc (Some d ds) !e = f (acc +## encodeDouble# d e)
115 ds
116 -- XXX We assume that this adding to e
117 -- isn't going to overflow
118 (e +# WORD_SIZE_IN_BITS#)
119 encodeDoubleInteger (Negative ds) e
120 = negateDouble# (encodeDoubleInteger (Positive ds) e)
121 encodeDoubleInteger Naught _ = 0.0##
122
123 foreign import ccall unsafe "__word_encodeDouble"
124 encodeDouble# :: Word# -> Int# -> Double#
125
126 encodeFloatInteger :: Integer -> Int# -> Float#
127 encodeFloatInteger (Positive ds0) e0 = f 0.0# ds0 e0
128 where f !acc None (!_) = acc
129 f !acc (Some d ds) !e = f (acc `plusFloat#` encodeFloat# d e)
130 ds
131 -- XXX We assume that this adding to e
132 -- isn't going to overflow
133 (e +# WORD_SIZE_IN_BITS#)
134 encodeFloatInteger (Negative ds) e
135 = negateFloat# (encodeFloatInteger (Positive ds) e)
136 encodeFloatInteger Naught _ = 0.0#
137
138 foreign import ccall unsafe "__word_encodeFloat"
139 encodeFloat# :: Word# -> Int# -> Float#
140
141 decodeFloatInteger :: Float# -> (# Integer, Int# #)
142 decodeFloatInteger f = case decodeFloat_Int# f of
143 (# mant, exp #) -> (# smallInteger mant, exp #)
144
145 -- XXX This could be optimised better, by either (word-size dependent)
146 -- using single 64bit value for the mantissa, or doing the multiplication
147 -- by just building the Digits directly
148 decodeDoubleInteger :: Double# -> (# Integer, Int# #)
149 decodeDoubleInteger d
150 = case decodeDouble_2Int# d of
151 (# mantSign, mantHigh, mantLow, exp #) ->
152 (# (smallInteger mantSign) `timesInteger`
153 ( (wordToInteger mantHigh `timesInteger` twoToTheThirtytwoInteger)
154 `plusInteger` wordToInteger mantLow),
155 exp #)
156
157 doubleFromInteger :: Integer -> Double#
158 doubleFromInteger Naught = 0.0##
159 doubleFromInteger (Positive p) = doubleFromPositive p
160 doubleFromInteger (Negative p) = negateDouble# (doubleFromPositive p)
161
162 floatFromInteger :: Integer -> Float#
163 floatFromInteger Naught = 0.0#
164 floatFromInteger (Positive p) = floatFromPositive p
165 floatFromInteger (Negative p) = negateFloat# (floatFromPositive p)
166
167 andInteger :: Integer -> Integer -> Integer
168 Naught `andInteger` (!_) = Naught
169 (!_) `andInteger` Naught = Naught
170 Positive x `andInteger` Positive y = digitsToInteger (x `andDigits` y)
171 {-
172 To calculate x & -y we need to calculate
173 x & twosComplement y
174 The (imaginary) sign bits are 0 and 1, so &ing them give 0, i.e. positive.
175 Note that
176 twosComplement y
177 has infinitely many 1s, but x has a finite number of digits, so andDigits
178 will return a finite result.
179 -}
180 Positive x `andInteger` Negative y = let y' = twosComplementPositive y
181 z = y' `andDigitsOnes` x
182 in digitsToInteger z
183 Negative x `andInteger` Positive y = Positive y `andInteger` Negative x
184 {-
185 To calculate -x & -y, naively we need to calculate
186 twosComplement (twosComplement x & twosComplement y)
187 but
188 twosComplement x & twosComplement y
189 has infinitely many 1s, so this won't work. Thus we use de Morgan's law
190 to get
191 -x & -y = !(!(-x) | !(-y))
192 = !(!(twosComplement x) | !(twosComplement y))
193 = !(!(!x + 1) | (!y + 1))
194 = !((x - 1) | (y - 1))
195 but the result is negative, so we need to take the two's complement of
196 this in order to get the magnitude of the result.
197 twosComplement !((x - 1) | (y - 1))
198 = !(!((x - 1) | (y - 1))) + 1
199 = ((x - 1) | (y - 1)) + 1
200 -}
201 -- We don't know that x and y are /strictly/ greater than 1, but
202 -- minusPositive gives us the required answer anyway.
203 Negative x `andInteger` Negative y = let x' = x `minusPositive` onePositive
204 y' = y `minusPositive` onePositive
205 z = x' `orDigits` y'
206 -- XXX Cheating the precondition:
207 z' = succPositive z
208 in digitsToNegativeInteger z'
209
210 orInteger :: Integer -> Integer -> Integer
211 Naught `orInteger` (!i) = i
212 (!i) `orInteger` Naught = i
213 Positive x `orInteger` Positive y = Positive (x `orDigits` y)
214 {-
215 x | -y = - (twosComplement (x | twosComplement y))
216 = - (twosComplement !(!x & !(twosComplement y)))
217 = - (twosComplement !(!x & !(!y + 1)))
218 = - (twosComplement !(!x & (y - 1)))
219 = - ((!x & (y - 1)) + 1)
220 -}
221 Positive x `orInteger` Negative y = let x' = flipBits x
222 y' = y `minusPositive` onePositive
223 z = x' `andDigitsOnes` y'
224 z' = succPositive z
225 in digitsToNegativeInteger z'
226 Negative x `orInteger` Positive y = Positive y `orInteger` Negative x
227 {-
228 -x | -y = - (twosComplement (twosComplement x | twosComplement y))
229 = - (twosComplement !(!(twosComplement x) & !(twosComplement y)))
230 = - (twosComplement !(!(!x + 1) & !(!y + 1)))
231 = - (twosComplement !((x - 1) & (y - 1)))
232 = - (((x - 1) & (y - 1)) + 1)
233 -}
234 Negative x `orInteger` Negative y = let x' = x `minusPositive` onePositive
235 y' = y `minusPositive` onePositive
236 z = x' `andDigits` y'
237 z' = succPositive z
238 in digitsToNegativeInteger z'
239
240 xorInteger :: Integer -> Integer -> Integer
241 Naught `xorInteger` (!i) = i
242 (!i) `xorInteger` Naught = i
243 Positive x `xorInteger` Positive y = digitsToInteger (x `xorDigits` y)
244 {-
245 x ^ -y = - (twosComplement (x ^ twosComplement y))
246 = - (twosComplement !(x ^ !(twosComplement y)))
247 = - (twosComplement !(x ^ !(!y + 1)))
248 = - (twosComplement !(x ^ (y - 1)))
249 = - ((x ^ (y - 1)) + 1)
250 -}
251 Positive x `xorInteger` Negative y = let y' = y `minusPositive` onePositive
252 z = x `xorDigits` y'
253 z' = succPositive z
254 in digitsToNegativeInteger z'
255 Negative x `xorInteger` Positive y = Positive y `xorInteger` Negative x
256 {-
257 -x ^ -y = twosComplement x ^ twosComplement y
258 = (!x + 1) ^ (!y + 1)
259 = (!x + 1) ^ (!y + 1)
260 = !(!x + 1) ^ !(!y + 1)
261 = (x - 1) ^ (y - 1)
262 -}
263 Negative x `xorInteger` Negative y = let x' = x `minusPositive` onePositive
264 y' = y `minusPositive` onePositive
265 z = x' `xorDigits` y'
266 in digitsToInteger z
267
268 complementInteger :: Integer -> Integer
269 complementInteger x = negativeOneInteger `minusInteger` x
270
271 twosComplementPositive :: Positive -> DigitsOnes
272 twosComplementPositive p = flipBits (p `minusPositive` onePositive)
273
274 flipBits :: Digits -> DigitsOnes
275 flipBits ds = DigitsOnes (flipBitsDigits ds)
276
277 flipBitsDigits :: Digits -> Digits
278 flipBitsDigits None = None
279 flipBitsDigits (Some w ws) = Some (not# w) (flipBitsDigits ws)
280
281 negateInteger :: Integer -> Integer
282 negateInteger (Positive p) = Negative p
283 negateInteger (Negative p) = Positive p
284 negateInteger Naught = Naught
285
286 plusInteger :: Integer -> Integer -> Integer
287 Positive p1 `plusInteger` Positive p2 = Positive (p1 `plusPositive` p2)
288 Negative p1 `plusInteger` Negative p2 = Negative (p1 `plusPositive` p2)
289 Positive p1 `plusInteger` Negative p2 = case p1 `comparePositive` p2 of
290 GT -> Positive (p1 `minusPositive` p2)
291 EQ -> Naught
292 LT -> Negative (p2 `minusPositive` p1)
293 Negative p1 `plusInteger` Positive p2 = Positive p2 `plusInteger` Negative p1
294 Naught `plusInteger` (!i) = i
295 (!i) `plusInteger` Naught = i
296
297 minusInteger :: Integer -> Integer -> Integer
298 i1 `minusInteger` i2 = i1 `plusInteger` negateInteger i2
299
300 timesInteger :: Integer -> Integer -> Integer
301 Positive p1 `timesInteger` Positive p2 = Positive (p1 `timesPositive` p2)
302 Negative p1 `timesInteger` Negative p2 = Positive (p1 `timesPositive` p2)
303 Positive p1 `timesInteger` Negative p2 = Negative (p1 `timesPositive` p2)
304 Negative p1 `timesInteger` Positive p2 = Negative (p1 `timesPositive` p2)
305 (!_) `timesInteger` (!_) = Naught
306
307 divModInteger :: Integer -> Integer -> (# Integer, Integer #)
308 n `divModInteger` d =
309 case n `quotRemInteger` d of
310 (# q, r #) ->
311 if signumInteger r `eqInteger`
312 negateInteger (signumInteger d)
313 then (# q `minusInteger` oneInteger, r `plusInteger` d #)
314 else (# q, r #)
315
316 quotRemInteger :: Integer -> Integer -> (# Integer, Integer #)
317 Naught `quotRemInteger` (!_) = (# Naught, Naught #)
318 (!_) `quotRemInteger` Naught
319 = (# errorInteger, errorInteger #) -- XXX Can't happen
320 -- XXX _ `quotRemInteger` Naught = error "Division by zero"
321 Positive p1 `quotRemInteger` Positive p2 = p1 `quotRemPositive` p2
322 Negative p1 `quotRemInteger` Positive p2 = case p1 `quotRemPositive` p2 of
323 (# q, r #) ->
324 (# negateInteger q,
325 negateInteger r #)
326 Positive p1 `quotRemInteger` Negative p2 = case p1 `quotRemPositive` p2 of
327 (# q, r #) ->
328 (# negateInteger q, r #)
329 Negative p1 `quotRemInteger` Negative p2 = case p1 `quotRemPositive` p2 of
330 (# q, r #) ->
331 (# q, negateInteger r #)
332
333 quotInteger :: Integer -> Integer -> Integer
334 x `quotInteger` y = case x `quotRemInteger` y of
335 (# q, _ #) -> q
336
337 remInteger :: Integer -> Integer -> Integer
338 x `remInteger` y = case x `quotRemInteger` y of
339 (# _, r #) -> r
340
341 compareInteger :: Integer -> Integer -> Ordering
342 Positive x `compareInteger` Positive y = x `comparePositive` y
343 Positive _ `compareInteger` (!_) = GT
344 Naught `compareInteger` Naught = EQ
345 Naught `compareInteger` Negative _ = GT
346 Negative x `compareInteger` Negative y = y `comparePositive` x
347 (!_) `compareInteger` (!_) = LT
348
349 eqInteger :: Integer -> Integer -> Bool
350 x `eqInteger` y = case x `compareInteger` y of
351 EQ -> True
352 _ -> False
353
354 neqInteger :: Integer -> Integer -> Bool
355 x `neqInteger` y = case x `compareInteger` y of
356 EQ -> False
357 _ -> True
358
359 ltInteger :: Integer -> Integer -> Bool
360 x `ltInteger` y = case x `compareInteger` y of
361 LT -> True
362 _ -> False
363
364 gtInteger :: Integer -> Integer -> Bool
365 x `gtInteger` y = case x `compareInteger` y of
366 GT -> True
367 _ -> False
368
369 leInteger :: Integer -> Integer -> Bool
370 x `leInteger` y = case x `compareInteger` y of
371 GT -> False
372 _ -> True
373
374 geInteger :: Integer -> Integer -> Bool
375 x `geInteger` y = case x `compareInteger` y of
376 LT -> False
377 _ -> True
378
379 absInteger :: Integer -> Integer
380 absInteger (Negative x) = Positive x
381 absInteger x = x
382
383 signumInteger :: Integer -> Integer
384 signumInteger (Negative _) = negativeOneInteger
385 signumInteger Naught = Naught
386 signumInteger (Positive _) = oneInteger
387
388 -- XXX This isn't a great hash function
389 hashInteger :: Integer -> Int#
390 hashInteger (!_) = 42#
391
392 -------------------------------------------------------------------
393 -- The hard work is done on positive numbers
394
395 -- Least significant bit is first
396
397 -- Positive's have the property that they contain at least one Bit,
398 -- and their last Bit is One.
399 type Positive = Digits
400 type Positives = List Positive
401
402 data Digits = Some !Digit !Digits
403 | None
404 type Digit = Word#
405
406 -- XXX Could move () above us
407 data Unit = Unit
408
409 -- XXX Could move [] above us
410 data List a = Nil | Cons a (List a)
411
412 onePositive :: Positive
413 onePositive = Some 1## None
414
415 halfBoundUp, fullBound :: Unit -> Digit
416 lowHalfMask :: Unit -> Digit
417 highHalfShift :: Unit -> Int#
418 twoToTheThirtytwoPositive :: Positive
419 #if WORD_SIZE_IN_BITS == 64
420 halfBoundUp Unit = 0x8000000000000000##
421 fullBound Unit = 0xFFFFFFFFFFFFFFFF##
422 lowHalfMask Unit = 0xFFFFFFFF##
423 highHalfShift Unit = 32#
424 twoToTheThirtytwoPositive = Some 0x100000000## None
425 #elif WORD_SIZE_IN_BITS == 32
426 halfBoundUp Unit = 0x80000000##
427 fullBound Unit = 0xFFFFFFFF##
428 lowHalfMask Unit = 0xFFFF##
429 highHalfShift Unit = 16#
430 twoToTheThirtytwoPositive = Some 0## (Some 1## None)
431 #else
432 #error Unhandled WORD_SIZE_IN_BITS
433 #endif
434
435 digitsMaybeZeroToInteger :: Digits -> Integer
436 digitsMaybeZeroToInteger None = Naught
437 digitsMaybeZeroToInteger ds = Positive ds
438
439 digitsToInteger :: Digits -> Integer
440 digitsToInteger ds = case removeZeroTails ds of
441 None -> Naught
442 ds' -> Positive ds'
443
444 digitsToNegativeInteger :: Digits -> Integer
445 digitsToNegativeInteger ds = case removeZeroTails ds of
446 None -> Naught
447 ds' -> Negative ds'
448
449 removeZeroTails :: Digits -> Digits
450 removeZeroTails (Some w ds) = if w `eqWord#` 0##
451 then case removeZeroTails ds of
452 None -> None
453 ds' -> Some w ds'
454 else Some w (removeZeroTails ds)
455 removeZeroTails None = None
456
457 #if WORD_SIZE_IN_BITS < 64
458 word64ToPositive :: Word64# -> Positive
459 word64ToPositive w
460 = if w `eqWord64#` wordToWord64# 0##
461 then None
462 else Some (word64ToWord# w) (word64ToPositive (w `uncheckedShiftRL64#` 32#))
463
464 positiveToWord64 :: Positive -> Word64#
465 positiveToWord64 None = wordToWord64# 0## -- XXX Can't happen
466 positiveToWord64 (Some w None) = wordToWord64# w
467 positiveToWord64 (Some low (Some high _))
468 = wordToWord64# low `or64#` (wordToWord64# high `uncheckedShiftL64#` 32#)
469 #endif
470
471 comparePositive :: Positive -> Positive -> Ordering
472 Some x xs `comparePositive` Some y ys = case xs `comparePositive` ys of
473 EQ -> if x `ltWord#` y then LT
474 else if x `gtWord#` y then GT
475 else EQ
476 res -> res
477 None `comparePositive` None = EQ
478 (!_) `comparePositive` None = GT
479 None `comparePositive` (!_) = LT
480
481 plusPositive :: Positive -> Positive -> Positive
482 plusPositive x0 y0 = addWithCarry 0## x0 y0
483 where -- digit `elem` [0, 1]
484 addWithCarry :: Digit -> Positive -> Positive -> Positive
485 addWithCarry c (!xs) None = addOnCarry c xs
486 addWithCarry c None (!ys) = addOnCarry c ys
487 addWithCarry c xs@(Some x xs') ys@(Some y ys')
488 = if x `ltWord#` y then addWithCarry c ys xs
489 -- Now x >= y
490 else if y `geWord#` halfBoundUp Unit
491 -- So they are both at least halfBoundUp, so we subtract
492 -- halfBoundUp from each and thus carry 1
493 then case x `minusWord#` halfBoundUp Unit of
494 x' ->
495 case y `minusWord#` halfBoundUp Unit of
496 y' ->
497 case x' `plusWord#` y' `plusWord#` c of
498 this ->
499 Some this withCarry
500 else if x `geWord#` halfBoundUp Unit
501 then case x `minusWord#` halfBoundUp Unit of
502 x' ->
503 case x' `plusWord#` y `plusWord#` c of
504 z ->
505 -- We've taken off halfBoundUp, so now we need to
506 -- add it back on
507 if z `ltWord#` halfBoundUp Unit
508 then Some (z `plusWord#` halfBoundUp Unit) withoutCarry
509 else Some (z `minusWord#` halfBoundUp Unit) withCarry
510 else Some (x `plusWord#` y `plusWord#` c) withoutCarry
511 where withCarry = addWithCarry 1## xs' ys'
512 withoutCarry = addWithCarry 0## xs' ys'
513
514 -- digit `elem` [0, 1]
515 addOnCarry :: Digit -> Positive -> Positive
516 addOnCarry (!c) (!ws) = if c `eqWord#` 0##
517 then ws
518 else succPositive ws
519
520 -- digit `elem` [0, 1]
521 succPositive :: Positive -> Positive
522 succPositive None = Some 1## None
523 succPositive (Some w ws) = if w `eqWord#` fullBound Unit
524 then Some 0## (succPositive ws)
525 else Some (w `plusWord#` 1##) ws
526
527 -- Requires x > y
528 -- In recursive calls, x >= y and x == y => result is None
529 minusPositive :: Positive -> Positive -> Positive
530 Some x xs `minusPositive` Some y ys
531 = if x `eqWord#` y
532 then case xs `minusPositive` ys of
533 None -> None
534 s -> Some 0## s
535 else if x `gtWord#` y then
536 Some (x `minusWord#` y) (xs `minusPositive` ys)
537 else case (fullBound Unit `minusWord#` y) `plusWord#` 1## of
538 z -> -- z = 2^n - y, calculated without overflow
539 case z `plusWord#` x of
540 z' -> -- z = 2^n + (x - y), calculated without overflow
541 Some z' ((xs `minusPositive` ys) `minusPositive` onePositive)
542 (!xs) `minusPositive` None = xs
543 None `minusPositive` (!_) = errorPositive -- XXX Can't happen
544 -- XXX None `minusPositive` _ = error "minusPositive: Requirement x > y not met"
545
546 timesPositive :: Positive -> Positive -> Positive
547 -- XXX None's can't happen here:
548 None `timesPositive` (!_) = errorPositive
549 (!_) `timesPositive` None = errorPositive
550 -- x and y are the last digits in Positive numbers, so are not 0:
551 Some x None `timesPositive` Some y None = x `timesDigit` y
552 xs@(Some _ None) `timesPositive` (!ys) = ys `timesPositive` xs
553 -- y is the last digit in a Positive number, so is not 0:
554 Some x xs' `timesPositive` ys@(Some y None)
555 = -- We could actually skip this test, and everything would
556 -- turn out OK. We already play tricks like that in timesPositive.
557 let zs = Some 0## (xs' `timesPositive` ys)
558 in if x `eqWord#` 0##
559 then zs
560 else (x `timesDigit` y) `plusPositive` zs
561 Some x xs' `timesPositive` ys@(Some _ _)
562 = (Some x None `timesPositive` ys) `plusPositive`
563 Some 0## (xs' `timesPositive` ys)
564
565 {-
566 -- Requires arguments /= 0
567 Suppose we have 2n bits in a Word. Then
568 x = 2^n xh + xl
569 y = 2^n yh + yl
570 x * y = (2^n xh + xl) * (2^n yh + yl)
571 = 2^(2n) (xh yh)
572 + 2^n (xh yl)
573 + 2^n (xl yh)
574 + (xl yl)
575 ~~~~~~~ - all fit in 2n bits
576 -}
577 timesDigit :: Digit -> Digit -> Positive
578 timesDigit (!x) (!y)
579 = case splitHalves x of
580 (# xh, xl #) ->
581 case splitHalves y of
582 (# yh, yl #) ->
583 case xh `timesWord#` yh of
584 xhyh ->
585 case splitHalves (xh `timesWord#` yl) of
586 (# xhylh, xhyll #) ->
587 case xhyll `uncheckedShiftL#` highHalfShift Unit of
588 xhyll' ->
589 case splitHalves (xl `timesWord#` yh) of
590 (# xlyhh, xlyhl #) ->
591 case xlyhl `uncheckedShiftL#` highHalfShift Unit of
592 xlyhl' ->
593 case xl `timesWord#` yl of
594 xlyl ->
595 -- Add up all the high word results. As the result fits in
596 -- 4n bits this can't overflow.
597 case xhyh `plusWord#` xhylh `plusWord#` xlyhh of
598 high ->
599 -- low: xhyll<<n + xlyhl<<n + xlyl
600 -- From this point we might make (Some 0 None), but we know
601 -- that the final result will be positive and the addition
602 -- will work out OK, so everything will work out in the end.
603 -- One thing we do need to be careful of is avoiding returning
604 -- Some 0 (Some 0 None) + Some n None, as this will result in
605 -- Some n (Some 0 None) instead of Some n None.
606 let low = Some xhyll' None `plusPositive`
607 Some xlyhl' None `plusPositive`
608 Some xlyl None
609 in if high `eqWord#` 0##
610 then low
611 else Some 0## (Some high None) `plusPositive` low
612
613 splitHalves :: Digit -> (# {- High -} Digit, {- Low -} Digit #)
614 splitHalves (!x) = (# x `uncheckedShiftRL#` highHalfShift Unit,
615 x `and#` lowHalfMask Unit #)
616
617 -- Assumes 0 <= i <= 31
618 shiftLPositive :: Positive -> Int# -> Positive
619 shiftLPositive None (!_) = None -- XXX Can't happen
620 shiftLPositive (!p) (!i) =
621 case WORD_SIZE_IN_BITS# -# i of
622 j -> let f carry None = if carry `eqWord#` 0##
623 then None
624 else Some carry None
625 f carry (Some w ws) = case w `uncheckedShiftRL#` j of
626 carry' ->
627 case w `uncheckedShiftL#` i of
628 me ->
629 Some (me `or#` carry) (f carry' ws)
630 in f 0## p
631
632 -- Long division
633 quotRemPositive :: Positive -> Positive -> (# Integer, Integer #)
634 (!xs) `quotRemPositive` (!ys)
635 = case f xs of
636 (# d, m #) -> (# digitsMaybeZeroToInteger d,
637 digitsMaybeZeroToInteger m #)
638 where
639 subtractors :: Positives
640 subtractors = mkSubtractors (WORD_SIZE_IN_BITS# -# 1#)
641
642 mkSubtractors (!n) = if n ==# 0#
643 then Cons ys Nil
644 else Cons (ys `shiftLPositive` n)
645 (mkSubtractors (n -# 1#))
646
647 -- The main function. Go the the end of xs, then walk
648 -- back trying to divide the number we accumulate by ys.
649 f :: Positive -> (# Digits, Digits #)
650 f None = (# None, None #)
651 f (Some z zs)
652 = case f zs of
653 (# ds, m #) ->
654 let -- We need to avoid making (Some Zero None) here
655 m' = some z m
656 in case g 0## subtractors m' of
657 (# d, m'' #) ->
658 (# some d ds, m'' #)
659
660 g :: Digit -> Positives -> Digits -> (# Digit, Digits #)
661 g (!d) Nil (!m) = (# d, m #)
662 g (!d) (Cons sub subs) (!m)
663 = case d `uncheckedShiftL#` 1# of
664 d' ->
665 case m `comparePositive` sub of
666 LT -> g d' subs m
667 _ -> g (d' `plusWord#` 1##)
668 subs
669 (m `minusPositive` sub)
670
671 some :: Digit -> Digits -> Digits
672 some (!w) None = if w `eqWord#` 0## then None else Some w None
673 some (!w) (!ws) = Some w ws
674
675 andDigits :: Digits -> Digits -> Digits
676 andDigits (!_) None = None
677 andDigits None (!_) = None
678 andDigits (Some w1 ws1) (Some w2 ws2) = Some (w1 `and#` w2) (andDigits ws1 ws2)
679
680 -- DigitsOnes is just like Digits, only None is really 0xFFFFFFF...,
681 -- i.e. ones off to infinity. This makes sense when we want to "and"
682 -- a DigitOnes with a Digits, as the latter will bound the size of the
683 -- result.
684 newtype DigitsOnes = DigitsOnes Digits
685
686 andDigitsOnes :: DigitsOnes -> Digits -> Digits
687 andDigitsOnes (!_) None = None
688 andDigitsOnes (DigitsOnes None) (!ws2) = ws2
689 andDigitsOnes (DigitsOnes (Some w1 ws1)) (Some w2 ws2)
690 = Some (w1 `and#` w2) (andDigitsOnes (DigitsOnes ws1) ws2)
691
692 orDigits :: Digits -> Digits -> Digits
693 orDigits None (!ds) = ds
694 orDigits (!ds) None = ds
695 orDigits (Some w1 ds1) (Some w2 ds2) = Some (w1 `or#` w2) (orDigits ds1 ds2)
696
697 xorDigits :: Digits -> Digits -> Digits
698 xorDigits None (!ds) = ds
699 xorDigits (!ds) None = ds
700 xorDigits (Some w1 ds1) (Some w2 ds2) = Some (w1 `xor#` w2) (xorDigits ds1 ds2)
701
702 -- XXX We'd really like word2Double# for this
703 doubleFromPositive :: Positive -> Double#
704 doubleFromPositive None = 0.0##
705 doubleFromPositive (Some w ds)
706 = case splitHalves w of
707 (# h, l #) ->
708 (doubleFromPositive ds *## (2.0## **## WORD_SIZE_IN_BITS.0##))
709 +## (int2Double# (word2Int# h) *##
710 (2.0## **## int2Double# (highHalfShift Unit)))
711 +## int2Double# (word2Int# l)
712
713 -- XXX We'd really like word2Float# for this
714 floatFromPositive :: Positive -> Float#
715 floatFromPositive None = 0.0#
716 floatFromPositive (Some w ds)
717 = case splitHalves w of
718 (# h, l #) ->
719 (floatFromPositive ds `timesFloat#` (2.0# `powerFloat#` WORD_SIZE_IN_BITS.0#))
720 `plusFloat#` (int2Float# (word2Int# h) `timesFloat#`
721 (2.0# `powerFloat#` int2Float# (highHalfShift Unit)))
722 `plusFloat#` int2Float# (word2Int# l)
723
724 #endif
725