mirror of
https://github.com/urbit/shrub.git
synced 2024-12-25 13:04:17 +03:00
urbit-atom: Back out of vendoring integer-simple.
This commit is contained in:
Benjamin Summers
parent
7e79c6d200
commit
14cba45597
@ -1,42 +0,0 @@
|
||||
{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Urbit.Atom.Simple
|
||||
-- Copyright : (c) Ian Lynagh 2007-2012
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : igloo@earth.li
|
||||
-- Stability : internal
|
||||
-- Portability : non-portable (GHC Extensions)
|
||||
--
|
||||
-- An simple definition of the 'Atom' type.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
#include "MachDeps.h"
|
||||
|
||||
module Urbit.Atom.Simple (
|
||||
Atom, mkAtom,
|
||||
smallAtom, wordToAtom, integerToWord, integerToInt,
|
||||
#if WORD_SIZE_IN_BITS < 64
|
||||
integerToWord64, word64ToAtom,
|
||||
integerToInt64, int64ToAtom,
|
||||
#endif
|
||||
plusAtom, minusAtom, timesAtom,
|
||||
eqAtom, neqAtom, absAtom, signumAtom,
|
||||
leAtom, gtAtom, ltAtom, geAtom, compareAtom,
|
||||
eqAtom#, neqAtom#,
|
||||
leAtom#, gtAtom#, ltAtom#, geAtom#,
|
||||
divAtom, modAtom,
|
||||
divModAtom, quotRemAtom, quotAtom, remAtom,
|
||||
encodeFloatAtom, decodeFloatAtom, floatFromAtom,
|
||||
encodeDoubleAtom, decodeDoubleAtom, doubleFromAtom,
|
||||
-- gcdAtom, lcmAtom, -- XXX
|
||||
andAtom, orAtom, xorAtom,
|
||||
shiftLAtom, shiftRAtom, testBitAtom,
|
||||
hashAtom,
|
||||
) where
|
||||
|
||||
import Urbit.Atom.Simple.Type
|
||||
|
||||
@ -1,23 +0,0 @@
|
||||
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Urbit.Atom.Simple.Internals
|
||||
-- Copyright : (c) Ian Lynagh 2007-2008
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : igloo@earth.li
|
||||
-- Stability : internal
|
||||
-- Portability : non-portable (GHC Extensions)
|
||||
--
|
||||
-- An simple definition of the 'Atom' type.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Urbit.Atom.Simple.Internals (
|
||||
module Urbit.Atom.Simple.Type
|
||||
) where
|
||||
|
||||
import Urbit.Atom.Simple.Type
|
||||
|
||||
@ -1,43 +0,0 @@
|
||||
{-# LANGUAGE MagicHash, UnboxedTuples, NoImplicitPrelude #-}
|
||||
module Urbit.Atom.Simple.Logarithms
|
||||
( integerLogBase#
|
||||
, integerLog2#
|
||||
, wordLog2#
|
||||
) where
|
||||
|
||||
import GHC.Prim
|
||||
import Urbit.Atom.Simple
|
||||
import qualified Urbit.Atom.Simple.Logarithms.Internals as I
|
||||
|
||||
-- | Calculate the integer logarithm for an arbitrary base.
|
||||
-- The base must be greater than 1, the second argument, the number
|
||||
-- whose logarithm is sought, should be positive, otherwise the
|
||||
-- result is meaningless.
|
||||
--
|
||||
-- > base ^ integerLogBase# base m <= m < base ^ (integerLogBase# base m + 1)
|
||||
--
|
||||
-- for @base > 1@ and @m > 0@.
|
||||
integerLogBase# :: Atom -> Atom -> Int#
|
||||
integerLogBase# b m = case step b of
|
||||
(# _, e #) -> e
|
||||
where
|
||||
step pw =
|
||||
if m `ltAtom` pw
|
||||
then (# m, 0# #)
|
||||
else case step (pw `timesAtom` pw) of
|
||||
(# q, e #) ->
|
||||
if q `ltAtom` pw
|
||||
then (# q, 2# *# e #)
|
||||
else (# q `quotAtom` pw, 2# *# e +# 1# #)
|
||||
|
||||
-- | Calculate the integer base 2 logarithm of an 'Atom'.
|
||||
-- The calculation is more efficient than for the general case,
|
||||
-- on platforms with 32- or 64-bit words much more efficient.
|
||||
--
|
||||
-- The argument must be strictly positive, that condition is /not/ checked.
|
||||
integerLog2# :: Atom -> Int#
|
||||
integerLog2# = I.integerLog2#
|
||||
|
||||
-- | This function calculates the integer base 2 logarithm of a 'Word#'.
|
||||
wordLog2# :: Word# -> Int#
|
||||
wordLog2# = I.wordLog2#
|
||||
@ -1,166 +0,0 @@
|
||||
{-# LANGUAGE CPP, MagicHash, UnboxedTuples, NoImplicitPrelude #-}
|
||||
{-# OPTIONS_HADDOCK hide #-}
|
||||
|
||||
#include "MachDeps.h"
|
||||
|
||||
-- (Hopefully) Fast integer logarithms to base 2.
|
||||
-- integerLog2# and wordLog2# are of general usefulness,
|
||||
-- the others are only needed for a fast implementation of
|
||||
-- fromRational.
|
||||
-- Since they are needed in Urbit.Float, we must expose this
|
||||
-- module, but it should not show up in the docs.
|
||||
|
||||
module Urbit.Atom.Simple.Logarithms.Internals
|
||||
( integerLog2#
|
||||
, integerLog2IsPowerOf2#
|
||||
, wordLog2#
|
||||
, roundingMode#
|
||||
) where
|
||||
|
||||
import GHC.Prim
|
||||
import Urbit.Atom.Simple.Type
|
||||
import GHC.Types
|
||||
|
||||
default ()
|
||||
|
||||
-- When larger word sizes become common, add support for those,
|
||||
-- it's not hard, just tedious.
|
||||
#if (WORD_SIZE_IN_BITS != 32) && (WORD_SIZE_IN_BITS != 64)
|
||||
|
||||
-- We don't know whether the word has 30 bits or 128 or even more,
|
||||
-- so we can't start from the top, although that would be much more
|
||||
-- efficient.
|
||||
wordLog2# :: Word# -> Int#
|
||||
wordLog2# w = go 8# w
|
||||
where
|
||||
go acc u = case u `uncheckedShiftRL#` 8# of
|
||||
0## -> case leadingZeros of
|
||||
BA ba -> acc -# indexInt8Array# ba (word2Int# u)
|
||||
v -> go (acc +# 8#) v
|
||||
|
||||
#else
|
||||
|
||||
-- This one at least can also be done efficiently.
|
||||
-- wordLog2# 0## = -1#
|
||||
{-# INLINE wordLog2# #-}
|
||||
wordLog2# :: Word# -> Int#
|
||||
wordLog2# w =
|
||||
case leadingZeros of
|
||||
BA lz ->
|
||||
let zeros u = indexInt8Array# lz (word2Int# u) in
|
||||
#if WORD_SIZE_IN_BITS == 64
|
||||
case uncheckedShiftRL# w 56# of
|
||||
a ->
|
||||
if isTrue# (a `neWord#` 0##)
|
||||
then 64# -# zeros a
|
||||
else
|
||||
case uncheckedShiftRL# w 48# of
|
||||
b ->
|
||||
if isTrue# (b `neWord#` 0##)
|
||||
then 56# -# zeros b
|
||||
else
|
||||
case uncheckedShiftRL# w 40# of
|
||||
c ->
|
||||
if isTrue# (c `neWord#` 0##)
|
||||
then 48# -# zeros c
|
||||
else
|
||||
case uncheckedShiftRL# w 32# of
|
||||
d ->
|
||||
if isTrue# (d `neWord#` 0##)
|
||||
then 40# -# zeros d
|
||||
else
|
||||
#endif
|
||||
case uncheckedShiftRL# w 24# of
|
||||
e ->
|
||||
if isTrue# (e `neWord#` 0##)
|
||||
then 32# -# zeros e
|
||||
else
|
||||
case uncheckedShiftRL# w 16# of
|
||||
f ->
|
||||
if isTrue# (f `neWord#` 0##)
|
||||
then 24# -# zeros f
|
||||
else
|
||||
case uncheckedShiftRL# w 8# of
|
||||
g ->
|
||||
if isTrue# (g `neWord#` 0##)
|
||||
then 16# -# zeros g
|
||||
else 8# -# zeros w
|
||||
|
||||
#endif
|
||||
|
||||
-- Assumption: Atom is strictly positive,
|
||||
-- otherwise return -1# arbitrarily
|
||||
-- Going up in word-sized steps should not be too bad.
|
||||
integerLog2# :: Atom -> Int#
|
||||
integerLog2# (Positive digits) = step 0# digits
|
||||
where
|
||||
step acc (Some dig None) = acc +# wordLog2# dig
|
||||
step acc (Some _ digs) =
|
||||
step (acc +# WORD_SIZE_IN_BITS#) digs
|
||||
step acc None = acc -- should be impossible, throw error?
|
||||
integerLog2# _ = negateInt# 1#
|
||||
|
||||
-- Again, integer should be strictly positive
|
||||
integerLog2IsPowerOf2# :: Atom -> (# Int#, Int# #)
|
||||
integerLog2IsPowerOf2# (Positive digits) = couldBe 0# digits
|
||||
where
|
||||
couldBe acc (Some dig None) =
|
||||
(# acc +# wordLog2# dig, word2Int# (and# dig (minusWord# dig 1##)) #)
|
||||
couldBe acc (Some dig digs) =
|
||||
if isTrue# (eqWord# dig 0##)
|
||||
then couldBe (acc +# WORD_SIZE_IN_BITS#) digs
|
||||
else noPower (acc +# WORD_SIZE_IN_BITS#) digs
|
||||
couldBe acc None = (# acc, 1# #) -- should be impossible, error?
|
||||
noPower acc (Some dig None) =
|
||||
(# acc +# wordLog2# dig, 1# #)
|
||||
noPower acc (Some _ digs) =
|
||||
noPower (acc +# WORD_SIZE_IN_BITS#) digs
|
||||
noPower acc None = (# acc, 1# #) -- should be impossible, error?
|
||||
integerLog2IsPowerOf2# _ = (# negateInt# 1#, 1# #)
|
||||
|
||||
-- Assumption: Atom and Int# are strictly positive, Int# is less
|
||||
-- than logBase 2 of Atom, otherwise havoc ensues.
|
||||
-- Used only for the numerator in fromRational when the denominator
|
||||
-- is a power of 2.
|
||||
-- The Int# argument is log2 n minus the number of bits in the mantissa
|
||||
-- of the target type, i.e. the index of the first non-integral bit in
|
||||
-- the quotient.
|
||||
--
|
||||
-- 0# means round down (towards zero)
|
||||
-- 1# means we have a half-integer, round to even
|
||||
-- 2# means round up (away from zero)
|
||||
-- This function should probably be improved.
|
||||
roundingMode# :: Atom -> Int# -> Int#
|
||||
roundingMode# m h =
|
||||
case oneAtom `shiftLAtom` h of
|
||||
c -> case m `andAtom`
|
||||
((c `plusAtom` c) `minusAtom` oneAtom) of
|
||||
r ->
|
||||
if c `ltAtom` r
|
||||
then 2#
|
||||
else if c `gtAtom` r
|
||||
then 0#
|
||||
else 1#
|
||||
|
||||
-- Lookup table
|
||||
data BA = BA ByteArray#
|
||||
|
||||
leadingZeros :: BA
|
||||
leadingZeros =
|
||||
let mkArr s =
|
||||
case newByteArray# 256# s of
|
||||
(# s1, mba #) ->
|
||||
case writeInt8Array# mba 0# 9# s1 of
|
||||
s2 ->
|
||||
let fillA lim val idx st =
|
||||
if isTrue# (idx ==# 256#)
|
||||
then st
|
||||
else if isTrue# (idx <# lim)
|
||||
then case writeInt8Array# mba idx val st of
|
||||
nx -> fillA lim val (idx +# 1#) nx
|
||||
else fillA (2# *# lim) (val -# 1#) idx st
|
||||
in case fillA 2# 8# 1# s2 of
|
||||
s3 -> case unsafeFreezeByteArray# mba s3 of
|
||||
(# _, ba #) -> ba
|
||||
in case mkArr realWorld# of
|
||||
b -> BA b
|
||||
@ -1,750 +0,0 @@
|
||||
|
||||
{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude, BangPatterns, UnboxedTuples,
|
||||
UnliftedFFITypes #-}
|
||||
|
||||
-- Commentary of Integer library is located on the wiki:
|
||||
-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/Libraries/Integer
|
||||
--
|
||||
-- It gives an in-depth description of implementation details and
|
||||
-- decisions.
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Urbit.Integer.Type
|
||||
-- Copyright : (c) Ian Lynagh 2007-2012
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : igloo@earth.li
|
||||
-- Stability : internal
|
||||
-- Portability : non-portable (GHC Extensions)
|
||||
--
|
||||
-- An simple definition of the 'Atom' type.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
#include "MachDeps.h"
|
||||
|
||||
module Urbit.Atom.Simple.Type where
|
||||
|
||||
import Prelude (error)
|
||||
import GHC.Exception.Type (underflowException)
|
||||
import GHC.Prim
|
||||
import GHC.Classes
|
||||
import GHC.Types
|
||||
import GHC.Tuple ()
|
||||
#if WORD_SIZE_IN_BITS < 64
|
||||
import GHC.IntWord64
|
||||
#endif
|
||||
|
||||
data Atom = Positive !Positive | Naught
|
||||
|
||||
-------------------------------------------------------------------
|
||||
-- The hard work is done on positive numbers
|
||||
|
||||
-- Least significant bit is first
|
||||
|
||||
-- Positive's have the property that they contain at least one Bit,
|
||||
-- and their last Bit is One.
|
||||
type Positive = Digits
|
||||
type Positives = List Positive
|
||||
|
||||
data Digits = Some !Digit !Digits
|
||||
| None
|
||||
type Digit = Word#
|
||||
|
||||
-- XXX Could move [] above us
|
||||
data List a = Nil | Cons a (List a)
|
||||
|
||||
mkAtom :: [Int] -- absolute value in 31 bit chunks, least significant first
|
||||
-- ideally these would be Words rather than Ints, but
|
||||
-- we don't have Word available at the moment.
|
||||
-> Atom
|
||||
mkAtom is = f is
|
||||
where f [] = Naught
|
||||
f (I# i : is') = smallAtom i `orAtom` shiftLAtom (f is') 31#
|
||||
|
||||
errorAtom :: Atom
|
||||
errorAtom = Positive errorPositive
|
||||
|
||||
errorPositive :: Positive
|
||||
errorPositive = Some 47## None -- Random number
|
||||
|
||||
{-# NOINLINE underflowError #-}
|
||||
underflowError :: a
|
||||
underflowError = raise# underflowException
|
||||
|
||||
{-# NOINLINE smallAtom #-}
|
||||
smallAtom :: Int# -> Atom
|
||||
smallAtom i = if isTrue# (i >=# 0#) then wordToAtom (int2Word# i)
|
||||
else underflowError
|
||||
|
||||
{-# NOINLINE wordToAtom #-}
|
||||
wordToAtom :: Word# -> Atom
|
||||
wordToAtom w = if isTrue# (w `eqWord#` 0##)
|
||||
then Naught
|
||||
else Positive (Some w None)
|
||||
|
||||
{-# NOINLINE integerToWord #-}
|
||||
integerToWord :: Atom -> Word#
|
||||
integerToWord (Positive (Some w _)) = w
|
||||
-- Must be Naught by the invariant:
|
||||
integerToWord _ = 0##
|
||||
|
||||
{-# NOINLINE integerToInt #-}
|
||||
integerToInt :: Atom -> Int#
|
||||
integerToInt i = word2Int# (integerToWord i)
|
||||
|
||||
#if WORD_SIZE_IN_BITS == 64
|
||||
-- Nothing
|
||||
#elif WORD_SIZE_IN_BITS == 32
|
||||
{-# NOINLINE integerToWord64 #-}
|
||||
integerToWord64 :: Atom -> Word64#
|
||||
integerToWord64 i = int64ToWord64# (integerToInt64 i)
|
||||
|
||||
{-# NOINLINE word64ToAtom #-}
|
||||
word64ToAtom:: Word64# -> Atom
|
||||
word64ToAtom w = if isTrue# (w `eqWord64#` wordToWord64# 0##)
|
||||
then Naught
|
||||
else Positive (word64ToPositive w)
|
||||
|
||||
{-# NOINLINE integerToInt64 #-}
|
||||
integerToInt64 :: Atom -> Int64#
|
||||
integerToInt64 Naught = intToInt64# 0#
|
||||
integerToInt64 (Positive p) = word64ToInt64# (positiveToWord64 p)
|
||||
|
||||
{-# NOINLINE int64ToAtom #-}
|
||||
int64ToAtom :: Int64# -> Atom
|
||||
int64ToAtom i
|
||||
= if isTrue# (i `eqInt64#` intToInt64# 0#)
|
||||
then Naught
|
||||
else if isTrue# (i `gtInt64#` intToInt64# 0#)
|
||||
then Positive (word64ToPositive (int64ToWord64# i))
|
||||
#else
|
||||
#error WORD_SIZE_IN_BITS not supported
|
||||
#endif
|
||||
|
||||
oneAtom :: Atom
|
||||
oneAtom = Positive onePositive
|
||||
|
||||
twoToTheThirtytwoAtom :: Atom
|
||||
twoToTheThirtytwoAtom = Positive twoToTheThirtytwoPositive
|
||||
|
||||
{-# NOINLINE encodeDoubleAtom #-}
|
||||
encodeDoubleAtom :: Atom -> Int# -> Double#
|
||||
encodeDoubleAtom (Positive ds0) e0 = f 0.0## ds0 e0
|
||||
where f !acc None (!_) = acc
|
||||
f !acc (Some d ds) !e = f (acc +## encodeDouble# d e)
|
||||
ds
|
||||
-- XXX We assume that this adding to e
|
||||
-- isn't going to overflow
|
||||
(e +# WORD_SIZE_IN_BITS#)
|
||||
encodeDoubleAtom Naught _ = 0.0##
|
||||
|
||||
foreign import ccall unsafe "__word_encodeDouble"
|
||||
encodeDouble# :: Word# -> Int# -> Double#
|
||||
|
||||
{-# NOINLINE encodeFloatAtom #-}
|
||||
encodeFloatAtom :: Atom -> Int# -> Float#
|
||||
encodeFloatAtom (Positive ds0) e0 = f 0.0# ds0 e0
|
||||
where f !acc None (!_) = acc
|
||||
f !acc (Some d ds) !e = f (acc `plusFloat#` encodeFloat# d e)
|
||||
ds
|
||||
-- XXX We assume that this adding to e
|
||||
-- isn't going to overflow
|
||||
(e +# WORD_SIZE_IN_BITS#)
|
||||
encodeFloatAtom Naught _ = 0.0#
|
||||
|
||||
foreign import ccall unsafe "__word_encodeFloat"
|
||||
encodeFloat# :: Word# -> Int# -> Float#
|
||||
|
||||
{-# NOINLINE decodeFloatAtom #-}
|
||||
decodeFloatAtom :: Float# -> (# Atom, Int# #)
|
||||
decodeFloatAtom f = case decodeFloat_Int# f of
|
||||
(# mant, exp #) -> (# smallAtom mant, exp #)
|
||||
|
||||
-- XXX This could be optimised better, by either (word-size dependent)
|
||||
-- using single 64bit value for the mantissa, or doing the multiplication
|
||||
-- by just building the Digits directly
|
||||
{-# NOINLINE decodeDoubleAtom #-}
|
||||
decodeDoubleAtom :: Double# -> (# Atom, Int# #)
|
||||
decodeDoubleAtom d
|
||||
= case decodeDouble_2Int# d of
|
||||
(# mantSign, mantHigh, mantLow, exp #) ->
|
||||
(# (smallAtom mantSign) `timesAtom`
|
||||
( (wordToAtom mantHigh `timesAtom` twoToTheThirtytwoAtom)
|
||||
`plusAtom` wordToAtom mantLow),
|
||||
exp #)
|
||||
|
||||
{-# NOINLINE doubleFromAtom #-}
|
||||
doubleFromAtom :: Atom -> Double#
|
||||
doubleFromAtom Naught = 0.0##
|
||||
doubleFromAtom (Positive p) = doubleFromPositive p
|
||||
|
||||
{-# NOINLINE floatFromAtom #-}
|
||||
floatFromAtom :: Atom -> Float#
|
||||
floatFromAtom Naught = 0.0#
|
||||
floatFromAtom (Positive p) = floatFromPositive p
|
||||
|
||||
{-# NOINLINE andAtom #-}
|
||||
andAtom :: Atom -> Atom -> Atom
|
||||
Naught `andAtom` (!_) = Naught
|
||||
(!_) `andAtom` Naught = Naught
|
||||
Positive x `andAtom` Positive y = digitsToAtom (x `andDigits` y)
|
||||
|
||||
{-# NOINLINE orAtom #-}
|
||||
orAtom :: Atom -> Atom -> Atom
|
||||
Naught `orAtom` (!i) = i
|
||||
(!i) `orAtom` Naught = i
|
||||
Positive x `orAtom` Positive y = Positive (x `orDigits` y)
|
||||
|
||||
{-# NOINLINE xorAtom #-}
|
||||
xorAtom :: Atom -> Atom -> Atom
|
||||
Naught `xorAtom` (!i) = i
|
||||
(!i) `xorAtom` Naught = i
|
||||
Positive x `xorAtom` Positive y = digitsToAtom (x `xorDigits` y)
|
||||
|
||||
{-# NOINLINE shiftLAtom #-}
|
||||
shiftLAtom :: Atom -> Int# -> Atom
|
||||
shiftLAtom (Positive p) i = Positive (shiftLPositive p i)
|
||||
shiftLAtom Naught _ = Naught
|
||||
|
||||
{-# NOINLINE shiftRAtom #-}
|
||||
shiftRAtom :: Atom -> Int# -> Atom
|
||||
shiftRAtom (Positive p) i = shiftRPositive p i
|
||||
shiftRAtom Naught _ = Naught
|
||||
|
||||
-- XXX this could be a lot more efficient, but this is a quick
|
||||
-- reimplementation of the default Data.Bits instance, so that we can
|
||||
-- implement the Atom interface
|
||||
testBitAtom :: Atom -> Int# -> Bool
|
||||
testBitAtom x i = (x `andAtom` (oneAtom `shiftLAtom` i))
|
||||
`neqAtom` Naught
|
||||
|
||||
twosComplementPositive :: Positive -> DigitsOnes
|
||||
twosComplementPositive p = flipBits (p `minusPositive` onePositive)
|
||||
|
||||
flipBits :: Digits -> DigitsOnes
|
||||
flipBits ds = DigitsOnes (flipBitsDigits ds)
|
||||
|
||||
flipBitsDigits :: Digits -> Digits
|
||||
flipBitsDigits None = None
|
||||
flipBitsDigits (Some w ws) = Some (not# w) (flipBitsDigits ws)
|
||||
|
||||
-- Note [Avoid patError]
|
||||
{-# NOINLINE plusAtom #-}
|
||||
plusAtom :: Atom -> Atom -> Atom
|
||||
Positive p1 `plusAtom` Positive p2 = Positive (p1 `plusPositive` p2)
|
||||
Naught `plusAtom` Naught = Naught
|
||||
Naught `plusAtom` i@(Positive _) = i
|
||||
i@(Positive _) `plusAtom` Naught = i
|
||||
|
||||
{-# NOINLINE minusAtom #-}
|
||||
minusAtom :: Atom -> Atom -> Atom
|
||||
i1 `minusAtom` i2 = i1 `plusAtom` error "negateAtom i2"
|
||||
|
||||
{-# NOINLINE timesAtom #-}
|
||||
timesAtom :: Atom -> Atom -> Atom
|
||||
Positive p1 `timesAtom` Positive p2 = Positive (p1 `timesPositive` p2)
|
||||
(!_) `timesAtom` (!_) = Naught
|
||||
|
||||
{-# NOINLINE divModAtom #-}
|
||||
divModAtom :: Atom -> Atom -> (# Atom, Atom #)
|
||||
n `divModAtom` d =
|
||||
case n `quotRemAtom` d of
|
||||
(# q, r #) ->
|
||||
if signumAtom r `eqAtom`
|
||||
error "negateAtom (signumAtom d)"
|
||||
then (# q `minusAtom` oneAtom, r `plusAtom` d #)
|
||||
else (# q, r #)
|
||||
|
||||
{-# NOINLINE divAtom #-}
|
||||
divAtom :: Atom -> Atom -> Atom
|
||||
n `divAtom` d = quotient
|
||||
where (# quotient, _ #) = n `divModAtom` d
|
||||
|
||||
{-# NOINLINE modAtom #-}
|
||||
modAtom :: Atom -> Atom -> Atom
|
||||
n `modAtom` d = modulus
|
||||
where (# _, modulus #) = n `divModAtom` d
|
||||
|
||||
{-# NOINLINE quotRemAtom #-}
|
||||
quotRemAtom :: Atom -> Atom -> (# Atom, Atom #)
|
||||
Naught `quotRemAtom` (!_) = (# Naught, Naught #)
|
||||
(!_) `quotRemAtom` Naught
|
||||
= (# errorAtom, errorAtom #) -- XXX Can't happen
|
||||
-- XXX _ `quotRemAtom` Naught = error "Division by zero"
|
||||
Positive p1 `quotRemAtom` Positive p2 = p1 `quotRemPositive` p2
|
||||
|
||||
{-# NOINLINE quotAtom #-}
|
||||
quotAtom :: Atom -> Atom -> Atom
|
||||
x `quotAtom` y = case x `quotRemAtom` y of
|
||||
(# q, _ #) -> q
|
||||
|
||||
{-# NOINLINE remAtom #-}
|
||||
remAtom :: Atom -> Atom -> Atom
|
||||
x `remAtom` y = case x `quotRemAtom` y of
|
||||
(# _, r #) -> r
|
||||
|
||||
{-# NOINLINE compareAtom #-}
|
||||
compareAtom :: Atom -> Atom -> Ordering
|
||||
Positive x `compareAtom` Positive y = x `comparePositive` y
|
||||
Positive _ `compareAtom` (!_) = GT
|
||||
Naught `compareAtom` Naught = EQ
|
||||
(!_) `compareAtom` (!_) = LT
|
||||
|
||||
{-# NOINLINE eqAtom# #-}
|
||||
eqAtom# :: Atom -> Atom -> Int#
|
||||
x `eqAtom#` y = case x `compareAtom` y of
|
||||
EQ -> 1#
|
||||
_ -> 0#
|
||||
|
||||
{-# NOINLINE neqAtom# #-}
|
||||
neqAtom# :: Atom -> Atom -> Int#
|
||||
x `neqAtom#` y = case x `compareAtom` y of
|
||||
EQ -> 0#
|
||||
_ -> 1#
|
||||
|
||||
{-# INLINE eqAtom #-}
|
||||
{-# INLINE neqAtom #-}
|
||||
eqAtom, neqAtom :: Atom -> Atom -> Bool
|
||||
eqAtom a b = isTrue# (a `eqAtom#` b)
|
||||
neqAtom a b = isTrue# (a `neqAtom#` b)
|
||||
|
||||
instance Eq Atom where
|
||||
(==) = eqAtom
|
||||
(/=) = neqAtom
|
||||
|
||||
{-# NOINLINE ltAtom# #-}
|
||||
ltAtom# :: Atom -> Atom -> Int#
|
||||
x `ltAtom#` y = case x `compareAtom` y of
|
||||
LT -> 1#
|
||||
_ -> 0#
|
||||
|
||||
{-# NOINLINE gtAtom# #-}
|
||||
gtAtom# :: Atom -> Atom -> Int#
|
||||
x `gtAtom#` y = case x `compareAtom` y of
|
||||
GT -> 1#
|
||||
_ -> 0#
|
||||
|
||||
{-# NOINLINE leAtom# #-}
|
||||
leAtom# :: Atom -> Atom -> Int#
|
||||
x `leAtom#` y = case x `compareAtom` y of
|
||||
GT -> 0#
|
||||
_ -> 1#
|
||||
|
||||
{-# NOINLINE geAtom# #-}
|
||||
geAtom# :: Atom -> Atom -> Int#
|
||||
x `geAtom#` y = case x `compareAtom` y of
|
||||
LT -> 0#
|
||||
_ -> 1#
|
||||
|
||||
{-# INLINE leAtom #-}
|
||||
{-# INLINE ltAtom #-}
|
||||
{-# INLINE geAtom #-}
|
||||
{-# INLINE gtAtom #-}
|
||||
leAtom, gtAtom, ltAtom, geAtom :: Atom -> Atom -> Bool
|
||||
leAtom a b = isTrue# (a `leAtom#` b)
|
||||
gtAtom a b = isTrue# (a `gtAtom#` b)
|
||||
ltAtom a b = isTrue# (a `ltAtom#` b)
|
||||
geAtom a b = isTrue# (a `geAtom#` b)
|
||||
|
||||
instance Ord Atom where
|
||||
(<=) = leAtom
|
||||
(>) = gtAtom
|
||||
(<) = ltAtom
|
||||
(>=) = geAtom
|
||||
compare = compareAtom
|
||||
|
||||
{-# NOINLINE absAtom #-}
|
||||
absAtom :: Atom -> Atom
|
||||
absAtom x = x
|
||||
|
||||
{-# NOINLINE signumAtom #-}
|
||||
signumAtom :: Atom -> Atom
|
||||
signumAtom Naught = Naught
|
||||
signumAtom (Positive _) = oneAtom
|
||||
|
||||
{-# NOINLINE hashAtom #-}
|
||||
hashAtom :: Atom -> Int#
|
||||
hashAtom = integerToInt
|
||||
|
||||
-------------------------------------------------------------------
|
||||
-- The hard work is done on positive numbers
|
||||
|
||||
onePositive :: Positive
|
||||
onePositive = Some 1## None
|
||||
|
||||
halfBoundUp, fullBound :: () -> Digit
|
||||
lowHalfMask :: () -> Digit
|
||||
highHalfShift :: () -> Int#
|
||||
twoToTheThirtytwoPositive :: Positive
|
||||
#if WORD_SIZE_IN_BITS == 64
|
||||
halfBoundUp () = 0x8000000000000000##
|
||||
fullBound () = 0xFFFFFFFFFFFFFFFF##
|
||||
lowHalfMask () = 0xFFFFFFFF##
|
||||
highHalfShift () = 32#
|
||||
twoToTheThirtytwoPositive = Some 0x100000000## None
|
||||
#elif WORD_SIZE_IN_BITS == 32
|
||||
halfBoundUp () = 0x80000000##
|
||||
fullBound () = 0xFFFFFFFF##
|
||||
lowHalfMask () = 0xFFFF##
|
||||
highHalfShift () = 16#
|
||||
twoToTheThirtytwoPositive = Some 0## (Some 1## None)
|
||||
#else
|
||||
#error Unhandled WORD_SIZE_IN_BITS
|
||||
#endif
|
||||
|
||||
digitsMaybeZeroToAtom :: Digits -> Atom
|
||||
digitsMaybeZeroToAtom None = Naught
|
||||
digitsMaybeZeroToAtom ds = Positive ds
|
||||
|
||||
digitsToAtom :: Digits -> Atom
|
||||
digitsToAtom ds = case removeZeroTails ds of
|
||||
None -> Naught
|
||||
ds' -> Positive ds'
|
||||
|
||||
removeZeroTails :: Digits -> Digits
|
||||
removeZeroTails (Some w ds) = if isTrue# (w `eqWord#` 0##)
|
||||
then case removeZeroTails ds of
|
||||
None -> None
|
||||
ds' -> Some w ds'
|
||||
else Some w (removeZeroTails ds)
|
||||
removeZeroTails None = None
|
||||
|
||||
#if WORD_SIZE_IN_BITS < 64
|
||||
word64ToPositive :: Word64# -> Positive
|
||||
word64ToPositive w
|
||||
= if isTrue# (w `eqWord64#` wordToWord64# 0##)
|
||||
then None
|
||||
else Some (word64ToWord# w) (word64ToPositive (w `uncheckedShiftRL64#` 32#))
|
||||
|
||||
positiveToWord64 :: Positive -> Word64#
|
||||
positiveToWord64 None = wordToWord64# 0## -- XXX Can't happen
|
||||
positiveToWord64 (Some w None) = wordToWord64# w
|
||||
positiveToWord64 (Some low (Some high _))
|
||||
= wordToWord64# low `or64#` (wordToWord64# high `uncheckedShiftL64#` 32#)
|
||||
#endif
|
||||
|
||||
-- Note [Avoid patError]
|
||||
comparePositive :: Positive -> Positive -> Ordering
|
||||
Some x xs `comparePositive` Some y ys = case xs `comparePositive` ys of
|
||||
EQ -> if isTrue# (x `ltWord#` y) then LT
|
||||
else if isTrue# (x `gtWord#` y) then GT
|
||||
else EQ
|
||||
res -> res
|
||||
None `comparePositive` None = EQ
|
||||
(Some {}) `comparePositive` None = GT
|
||||
None `comparePositive` (Some {}) = LT
|
||||
|
||||
plusPositive :: Positive -> Positive -> Positive
|
||||
plusPositive x0 y0 = addWithCarry 0## x0 y0
|
||||
where -- digit `elem` [0, 1]
|
||||
-- Note [Avoid patError]
|
||||
addWithCarry :: Digit -> Positive -> Positive -> Positive
|
||||
addWithCarry c None None = addOnCarry c None
|
||||
addWithCarry c xs@(Some {}) None = addOnCarry c xs
|
||||
addWithCarry c None ys@(Some {}) = addOnCarry c ys
|
||||
addWithCarry c xs@(Some x xs') ys@(Some y ys')
|
||||
= if isTrue# (x `ltWord#` y) then addWithCarry c ys xs
|
||||
-- Now x >= y
|
||||
else if isTrue# (y `geWord#` halfBoundUp ())
|
||||
-- So they are both at least halfBoundUp, so we subtract
|
||||
-- halfBoundUp from each and thus carry 1
|
||||
then case x `minusWord#` halfBoundUp () of
|
||||
x' ->
|
||||
case y `minusWord#` halfBoundUp () of
|
||||
y' ->
|
||||
case x' `plusWord#` y' `plusWord#` c of
|
||||
this ->
|
||||
Some this withCarry
|
||||
else if isTrue# (x `geWord#` halfBoundUp ())
|
||||
then case x `minusWord#` halfBoundUp () of
|
||||
x' ->
|
||||
case x' `plusWord#` y `plusWord#` c of
|
||||
z ->
|
||||
-- We've taken off halfBoundUp, so now we need to
|
||||
-- add it back on
|
||||
if isTrue# (z `ltWord#` halfBoundUp ())
|
||||
then Some (z `plusWord#` halfBoundUp ()) withoutCarry
|
||||
else Some (z `minusWord#` halfBoundUp ()) withCarry
|
||||
else Some (x `plusWord#` y `plusWord#` c) withoutCarry
|
||||
where withCarry = addWithCarry 1## xs' ys'
|
||||
withoutCarry = addWithCarry 0## xs' ys'
|
||||
|
||||
-- digit `elem` [0, 1]
|
||||
addOnCarry :: Digit -> Positive -> Positive
|
||||
addOnCarry (!c) (!ws) = if isTrue# (c `eqWord#` 0##)
|
||||
then ws
|
||||
else succPositive ws
|
||||
|
||||
-- digit `elem` [0, 1]
|
||||
succPositive :: Positive -> Positive
|
||||
succPositive None = Some 1## None
|
||||
succPositive (Some w ws) = if isTrue# (w `eqWord#` fullBound ())
|
||||
then Some 0## (succPositive ws)
|
||||
else Some (w `plusWord#` 1##) ws
|
||||
|
||||
-- Requires x > y
|
||||
-- In recursive calls, x >= y and x == y => result is None
|
||||
-- Note [Avoid patError]
|
||||
minusPositive :: Positive -> Positive -> Positive
|
||||
Some x xs `minusPositive` Some y ys
|
||||
= if isTrue# (x `eqWord#` y)
|
||||
then case xs `minusPositive` ys of
|
||||
None -> None
|
||||
s -> Some 0## s
|
||||
else if isTrue# (x `gtWord#` y) then
|
||||
Some (x `minusWord#` y) (xs `minusPositive` ys)
|
||||
else case (fullBound () `minusWord#` y) `plusWord#` 1## of
|
||||
z -> -- z = 2^n - y, calculated without overflow
|
||||
case z `plusWord#` x of
|
||||
z' -> -- z = 2^n + (x - y), calculated without overflow
|
||||
Some z' ((xs `minusPositive` ys) `minusPositive` onePositive)
|
||||
xs@(Some {}) `minusPositive` None = xs
|
||||
None `minusPositive` None = None
|
||||
None `minusPositive` (Some {}) = errorPositive -- XXX Can't happen
|
||||
-- XXX None `minusPositive` _ = error "minusPositive: Requirement x > y not met"
|
||||
|
||||
-- Note [Avoid patError]
|
||||
timesPositive :: Positive -> Positive -> Positive
|
||||
-- XXX None's can't happen here:
|
||||
None `timesPositive` None = errorPositive
|
||||
None `timesPositive` (Some {}) = errorPositive
|
||||
(Some {}) `timesPositive` None = errorPositive
|
||||
-- x and y are the last digits in Positive numbers, so are not 0:
|
||||
xs@(Some x xs') `timesPositive` ys@(Some y ys')
|
||||
= case xs' of
|
||||
None ->
|
||||
case ys' of
|
||||
None ->
|
||||
x `timesDigit` y
|
||||
Some {} ->
|
||||
ys `timesPositive` xs
|
||||
Some {} ->
|
||||
case ys' of
|
||||
None ->
|
||||
-- y is the last digit in a Positive number, so is not 0.
|
||||
let zs = Some 0## (xs' `timesPositive` ys)
|
||||
in -- We could actually skip this test, and everything would
|
||||
-- turn out OK. We already play tricks like that in timesPositive.
|
||||
if isTrue# (x `eqWord#` 0##)
|
||||
then zs
|
||||
else (x `timesDigit` y) `plusPositive` zs
|
||||
Some {} ->
|
||||
(Some x None `timesPositive` ys) `plusPositive`
|
||||
Some 0## (xs' `timesPositive` ys)
|
||||
|
||||
{-
|
||||
-- Requires arguments /= 0
|
||||
Suppose we have 2n bits in a Word. Then
|
||||
x = 2^n xh + xl
|
||||
y = 2^n yh + yl
|
||||
x * y = (2^n xh + xl) * (2^n yh + yl)
|
||||
= 2^(2n) (xh yh)
|
||||
+ 2^n (xh yl)
|
||||
+ 2^n (xl yh)
|
||||
+ (xl yl)
|
||||
~~~~~~~ - all fit in 2n bits
|
||||
-}
|
||||
timesDigit :: Digit -> Digit -> Positive
|
||||
timesDigit (!x) (!y)
|
||||
= case splitHalves x of
|
||||
(# xh, xl #) ->
|
||||
case splitHalves y of
|
||||
(# yh, yl #) ->
|
||||
case xh `timesWord#` yh of
|
||||
xhyh ->
|
||||
case splitHalves (xh `timesWord#` yl) of
|
||||
(# xhylh, xhyll #) ->
|
||||
case xhyll `uncheckedShiftL#` highHalfShift () of
|
||||
xhyll' ->
|
||||
case splitHalves (xl `timesWord#` yh) of
|
||||
(# xlyhh, xlyhl #) ->
|
||||
case xlyhl `uncheckedShiftL#` highHalfShift () of
|
||||
xlyhl' ->
|
||||
case xl `timesWord#` yl of
|
||||
xlyl ->
|
||||
-- Add up all the high word results. As the result fits in
|
||||
-- 4n bits this can't overflow.
|
||||
case xhyh `plusWord#` xhylh `plusWord#` xlyhh of
|
||||
high ->
|
||||
-- low: xhyll<<n + xlyhl<<n + xlyl
|
||||
-- From this point we might make (Some 0 None), but we know
|
||||
-- that the final result will be positive and the addition
|
||||
-- will work out OK, so everything will work out in the end.
|
||||
-- One thing we do need to be careful of is avoiding returning
|
||||
-- Some 0 (Some 0 None) + Some n None, as this will result in
|
||||
-- Some n (Some 0 None) instead of Some n None.
|
||||
let low = Some xhyll' None `plusPositive`
|
||||
Some xlyhl' None `plusPositive`
|
||||
Some xlyl None
|
||||
in if isTrue# (high `eqWord#` 0##)
|
||||
then low
|
||||
else Some 0## (Some high None) `plusPositive` low
|
||||
|
||||
splitHalves :: Digit -> (# {- High -} Digit, {- Low -} Digit #)
|
||||
splitHalves (!x) = (# x `uncheckedShiftRL#` highHalfShift (),
|
||||
x `and#` lowHalfMask () #)
|
||||
|
||||
-- Assumes 0 <= i
|
||||
shiftLPositive :: Positive -> Int# -> Positive
|
||||
shiftLPositive p i
|
||||
= if isTrue# (i >=# WORD_SIZE_IN_BITS#)
|
||||
then shiftLPositive (Some 0## p) (i -# WORD_SIZE_IN_BITS#)
|
||||
else smallShiftLPositive p i
|
||||
|
||||
-- Assumes 0 <= i < WORD_SIZE_IN_BITS#
|
||||
smallShiftLPositive :: Positive -> Int# -> Positive
|
||||
smallShiftLPositive (!p) 0# = p
|
||||
smallShiftLPositive (!p) (!i) =
|
||||
case WORD_SIZE_IN_BITS# -# i of
|
||||
j -> let f carry None = if isTrue# (carry `eqWord#` 0##)
|
||||
then None
|
||||
else Some carry None
|
||||
f carry (Some w ws) = case w `uncheckedShiftRL#` j of
|
||||
carry' ->
|
||||
case w `uncheckedShiftL#` i of
|
||||
me ->
|
||||
Some (me `or#` carry) (f carry' ws)
|
||||
in f 0## p
|
||||
|
||||
-- Assumes 0 <= i
|
||||
shiftRPositive :: Positive -> Int# -> Atom
|
||||
shiftRPositive None _ = Naught
|
||||
shiftRPositive p@(Some _ q) i
|
||||
= if isTrue# (i >=# WORD_SIZE_IN_BITS#)
|
||||
then shiftRPositive q (i -# WORD_SIZE_IN_BITS#)
|
||||
else smallShiftRPositive p i
|
||||
|
||||
-- Assumes 0 <= i < WORD_SIZE_IN_BITS#
|
||||
smallShiftRPositive :: Positive -> Int# -> Atom
|
||||
smallShiftRPositive (!p) (!i) =
|
||||
if isTrue# (i ==# 0#)
|
||||
then Positive p
|
||||
else case smallShiftLPositive p (WORD_SIZE_IN_BITS# -# i) of
|
||||
Some _ p'@(Some _ _) -> Positive p'
|
||||
_ -> Naught
|
||||
|
||||
-- Long division
|
||||
quotRemPositive :: Positive -> Positive -> (# Atom, Atom #)
|
||||
(!xs) `quotRemPositive` (!ys)
|
||||
= case f xs of
|
||||
(# d, m #) -> (# digitsMaybeZeroToAtom d,
|
||||
digitsMaybeZeroToAtom m #)
|
||||
where
|
||||
subtractors :: Positives
|
||||
subtractors = mkSubtractors (WORD_SIZE_IN_BITS# -# 1#)
|
||||
|
||||
mkSubtractors (!n) = if isTrue# (n ==# 0#)
|
||||
then Cons ys Nil
|
||||
else Cons (ys `smallShiftLPositive` n)
|
||||
(mkSubtractors (n -# 1#))
|
||||
|
||||
-- The main function. Go the the end of xs, then walk
|
||||
-- back trying to divide the number we accumulate by ys.
|
||||
f :: Positive -> (# Digits, Digits #)
|
||||
f None = (# None, None #)
|
||||
f (Some z zs)
|
||||
= case f zs of
|
||||
(# ds, m #) ->
|
||||
let -- We need to avoid making (Some Zero None) here
|
||||
m' = some z m
|
||||
in case g 0## subtractors m' of
|
||||
(# d, m'' #) ->
|
||||
(# some d ds, m'' #)
|
||||
|
||||
g :: Digit -> Positives -> Digits -> (# Digit, Digits #)
|
||||
g (!d) Nil (!m) = (# d, m #)
|
||||
g (!d) (Cons sub subs) (!m)
|
||||
= case d `uncheckedShiftL#` 1# of
|
||||
d' ->
|
||||
case m `comparePositive` sub of
|
||||
LT -> g d' subs m
|
||||
_ -> g (d' `plusWord#` 1##)
|
||||
subs
|
||||
(m `minusPositive` sub)
|
||||
|
||||
some :: Digit -> Digits -> Digits
|
||||
some (!w) None = if isTrue# (w `eqWord#` 0##) then None else Some w None
|
||||
some (!w) (!ws) = Some w ws
|
||||
|
||||
-- Note [Avoid patError]
|
||||
andDigits :: Digits -> Digits -> Digits
|
||||
andDigits None None = None
|
||||
andDigits (Some {}) None = None
|
||||
andDigits None (Some {}) = None
|
||||
andDigits (Some w1 ws1) (Some w2 ws2) = Some (w1 `and#` w2) (andDigits ws1 ws2)
|
||||
|
||||
-- DigitsOnes is just like Digits, only None is really 0xFFFFFFF...,
|
||||
-- i.e. ones off to infinity. This makes sense when we want to "and"
|
||||
-- a DigitOnes with a Digits, as the latter will bound the size of the
|
||||
-- result.
|
||||
newtype DigitsOnes = DigitsOnes Digits
|
||||
|
||||
-- Note [Avoid patError]
|
||||
andDigitsOnes :: DigitsOnes -> Digits -> Digits
|
||||
andDigitsOnes (DigitsOnes None) None = None
|
||||
andDigitsOnes (DigitsOnes None) ws2@(Some {}) = ws2
|
||||
andDigitsOnes (DigitsOnes (Some {})) None = None
|
||||
andDigitsOnes (DigitsOnes (Some w1 ws1)) (Some w2 ws2)
|
||||
= Some (w1 `and#` w2) (andDigitsOnes (DigitsOnes ws1) ws2)
|
||||
|
||||
-- Note [Avoid patError]
|
||||
orDigits :: Digits -> Digits -> Digits
|
||||
orDigits None None = None
|
||||
orDigits None ds@(Some {}) = ds
|
||||
orDigits ds@(Some {}) None = ds
|
||||
orDigits (Some w1 ds1) (Some w2 ds2) = Some (w1 `or#` w2) (orDigits ds1 ds2)
|
||||
|
||||
-- Note [Avoid patError]
|
||||
xorDigits :: Digits -> Digits -> Digits
|
||||
xorDigits None None = None
|
||||
xorDigits None ds@(Some {}) = ds
|
||||
xorDigits ds@(Some {}) None = ds
|
||||
xorDigits (Some w1 ds1) (Some w2 ds2) = Some (w1 `xor#` w2) (xorDigits ds1 ds2)
|
||||
|
||||
-- XXX We'd really like word2Double# for this
|
||||
doubleFromPositive :: Positive -> Double#
|
||||
doubleFromPositive None = 0.0##
|
||||
doubleFromPositive (Some w ds)
|
||||
= case splitHalves w of
|
||||
(# h, l #) ->
|
||||
(doubleFromPositive ds *## (2.0## **## WORD_SIZE_IN_BITS_FLOAT##))
|
||||
+## (int2Double# (word2Int# h) *##
|
||||
(2.0## **## int2Double# (highHalfShift ())))
|
||||
+## int2Double# (word2Int# l)
|
||||
|
||||
-- XXX We'd really like word2Float# for this
|
||||
floatFromPositive :: Positive -> Float#
|
||||
floatFromPositive None = 0.0#
|
||||
floatFromPositive (Some w ds)
|
||||
= case splitHalves w of
|
||||
(# h, l #) ->
|
||||
(floatFromPositive ds `timesFloat#` (2.0# `powerFloat#` WORD_SIZE_IN_BITS_FLOAT#))
|
||||
`plusFloat#` (int2Float# (word2Int# h) `timesFloat#`
|
||||
(2.0# `powerFloat#` int2Float# (highHalfShift ())))
|
||||
`plusFloat#` int2Float# (word2Int# l)
|
||||
|
||||
{-
|
||||
Note [Avoid patError]
|
||||
|
||||
If we use the natural set of definitions for functions, e.g.:
|
||||
|
||||
orDigits None ds = ds
|
||||
orDigits ds None = ds
|
||||
orDigits (Some w1 ds1) (Some w2 ds2) = Some ... ...
|
||||
|
||||
then GHC may not be smart enough (especially when compiling with -O0)
|
||||
to see that all the cases are handled, and will thus insert calls to
|
||||
base:Control.Exception.Base.patError. But we are below base in the
|
||||
package hierarchy, so this causes build failure!
|
||||
|
||||
We therefore help GHC out, by being more explicit about what all the
|
||||
cases are:
|
||||
|
||||
orDigits None None = None
|
||||
orDigits None ds@(Some {}) = ds
|
||||
orDigits ds@(Some {}) None = ds
|
||||
orDigits (Some w1 ds1) (Some w2 ds2) = Some ... ...
|
||||
-}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user