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