1-- |
2-- Module:      GHC.Integer.Logarithms.Compat
3-- Copyright:   (c) 2011 Daniel Fischer
4-- Licence:     MIT
5-- Maintainer:  Daniel Fischer <daniel.is.fischer@googlemail.com>
6-- Stability:   Provisional
7-- Portability: Non-portable (GHC extensions)
8--
9-- Low level stuff for integer logarithms.
10{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
11#if __GLASGOW_HASKELL__ >= 702
12{-# LANGUAGE Trustworthy #-}
13#endif
14module GHC.Integer.Logarithms.Compat
15    ( -- * Functions
16      integerLogBase#
17    , integerLog2#
18    , wordLog2#
19    ) where
20
21#if __GLASGOW_HASKELL__ >= 702
22
23-- Stuff is already there
24import GHC.Integer.Logarithms
25
26#else
27
28-- We have to define it here
29#include "MachDeps.h"
30
31import GHC.Base
32import GHC.Integer.GMP.Internals
33
34#if (WORD_SIZE_IN_BITS != 32) && (WORD_SIZE_IN_BITS != 64)
35#error Only word sizes 32 and 64 are supported.
36#endif
37
38
39#if WORD_SIZE_IN_BITS == 32
40
41#define WSHIFT 5
42#define MMASK 31
43
44#else
45
46#define WSHIFT 6
47#define MMASK 63
48
49#endif
50
51-- Reference implementation only, the algorithm in M.NT.Logarithms is better.
52
53-- | Calculate the integer logarithm for an arbitrary base.
54--   The base must be greater than 1, the second argument, the number
55--   whose logarithm is sought; should be positive, otherwise the
56--   result is meaningless.
57--
58-- > base ^ integerLogBase# base m <= m < base ^ (integerLogBase# base m + 1)
59--
60-- for @base > 1@ and @m > 0@.
61integerLogBase# :: Integer -> Integer -> Int#
62integerLogBase# b m = case step b of
63                        (# _, e #) -> e
64  where
65    step pw =
66      if m < pw
67        then (# m, 0# #)
68        else case step (pw * pw) of
69               (# q, e #) ->
70                 if q < pw
71                   then (# q, 2# *# e #)
72                   else (# q `quot` pw, 2# *# e +# 1# #)
73
74-- | Calculate the integer base 2 logarithm of an 'Integer'.
75--   The calculation is much more efficient than for the general case.
76--
77--   The argument must be strictly positive, that condition is /not/ checked.
78integerLog2# :: Integer -> Int#
79integerLog2# (S# i) = wordLog2# (int2Word# i)
80integerLog2# (J# s ba) = check (s -# 1#)
81  where
82    check i = case indexWordArray# ba i of
83                0## -> check (i -# 1#)
84                w   -> wordLog2# w +# (uncheckedIShiftL# i WSHIFT#)
85
86-- | This function calculates the integer base 2 logarithm of a 'Word#'.
87--   @'wordLog2#' 0## = -1#@.
88{-# INLINE wordLog2# #-}
89wordLog2# :: Word# -> Int#
90wordLog2# w =
91  case leadingZeros of
92   BA lz ->
93    let zeros u = indexInt8Array# lz (word2Int# u) in
94#if WORD_SIZE_IN_BITS == 64
95    case uncheckedShiftRL# w 56# of
96     a ->
97      if a `neWord#` 0##
98       then 64# -# zeros a
99       else
100        case uncheckedShiftRL# w 48# of
101         b ->
102          if b `neWord#` 0##
103           then 56# -# zeros b
104           else
105            case uncheckedShiftRL# w 40# of
106             c ->
107              if c `neWord#` 0##
108               then 48# -# zeros c
109               else
110                case uncheckedShiftRL# w 32# of
111                 d ->
112                  if d `neWord#` 0##
113                   then 40# -# zeros d
114                   else
115#endif
116                    case uncheckedShiftRL# w 24# of
117                     e ->
118                      if e `neWord#` 0##
119                       then 32# -# zeros e
120                       else
121                        case uncheckedShiftRL# w 16# of
122                         f ->
123                          if f `neWord#` 0##
124                           then 24# -# zeros f
125                           else
126                            case uncheckedShiftRL# w 8# of
127                             g ->
128                              if g `neWord#` 0##
129                               then 16# -# zeros g
130                               else 8# -# zeros w
131
132-- Lookup table
133data BA = BA ByteArray#
134
135leadingZeros :: BA
136leadingZeros =
137    let mkArr s =
138          case newByteArray# 256# s of
139            (# s1, mba #) ->
140              case writeInt8Array# mba 0# 9# s1 of
141                s2 ->
142                  let fillA lim val idx st =
143                        if idx ==# 256#
144                          then st
145                          else if idx <# lim
146                                then case writeInt8Array# mba idx val st of
147                                        nx -> fillA lim val (idx +# 1#) nx
148                                else fillA (2# *# lim) (val -# 1#) idx st
149                  in case fillA 2# 8# 1# s2 of
150                      s3 -> case unsafeFreezeByteArray# mba s3 of
151                              (# _, ba #) -> ba
152    in case mkArr realWorld# of
153        b -> BA b
154
155#endif
156