{-# LANGUAGE CPP, MagicHash, UnboxedTuples, NoImplicitPrelude #-}
{-# OPTIONS_HADDOCK hide #-}
#ifdef ghcjs_HOST_OS
{-# LANGUAGE JavaScriptFFI, UnliftedFFITypes #-}
#endif

#include "MachDeps.h"

-- 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 GHC.Float, we must expose this
-- module, but it should not show up in the docs.

module GHC.Integer.Logarithms.Internals
    ( integerLog2#
    , integerLog2IsPowerOf2#
    , wordLog2#
    , roundingMode#
    ) where

import GHC.Prim
import GHC.Types (isTrue#)
import GHC.Integer.Type

#if defined(ghcjs_HOST_OS)

foreign import javascript unsafe
  "h$integer_wordLog2($1)"
  wordLog2# :: Word# -> Int#

foreign import javascript unsafe
  "h$integer_integerLog2($1)"
  js_integerLog2 :: ByteArray# -> Int#

foreign import javascript unsafe
  "$r1 = h$integer_integerLog2IsPowerOf2($1); $r2 = h$ret1;"
  js_integerLog2IsPowerOf2 :: ByteArray# -> (# Int#, Int# #)

foreign import javascript unsafe
  "$r1 = h$integer_intLog2IsPowerOf2($1); $r2 = h$ret1;"
  js_intLog2IsPowerOf2 :: Int# -> (# Int#, Int# #)

foreign import javascript unsafe
  "h$integer_roundingMode($1,$2)"
  js_roundingMode :: ByteArray# -> Int# -> Int#

integerLog2# :: Integer -> Int#
integerLog2# (S# i)    = wordLog2# (int2Word# i)
integerLog2# (J# _ ba) = js_integerLog2 ba

integerLog2IsPowerOf2# :: Integer -> (# Int#, Int# #)
integerLog2IsPowerOf2# (S# i)    = js_intLog2IsPowerOf2 i
integerLog2IsPowerOf2# (J# _ ba) = js_integerLog2IsPowerOf2 ba

roundingMode# :: Integer -> Int# -> Int#
roundingMode# (S# i) t =
    case int2Word# i `and#` ((uncheckedShiftL# 2## t) `minusWord#` 1##) of
      k -> case uncheckedShiftL# 1## t of
            c -> if isTrue# (c `gtWord#` k)
                    then 0#
                    else if isTrue# (c `ltWord#` k)
                            then 2#
                            else 1#
roundingMode# (J# _ ba) t = js_roundingMode ba t

-- When larger word sizes become common, add support for those,
-- it is not hard, just tedious.
#elif ((WORD_SIZE_IN_BITS != 32) && (WORD_SIZE_IN_BITS != 64))

-- Less than ideal implementations for strange word sizes

-- import GHC.Integer

default ()

-- We do not know whether the word has 30 bits or 128 or even more,
-- so we cannot start from the top, although that would be much more
-- efficient.
-- Count the bits until the highest set bit is found.
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

-- Assumption: Integer is strictly positive
integerLog2# :: Integer -> Int#
integerLog2# (S# i) = wordLog2# (int2Word# i) -- that is easy
integerLog2# m = case step m (smallInteger 2#) 1# of
                    (# _, l #) -> l
  where
    -- Invariants:
    -- pw = 2 ^ lg
    -- case step n pw lg of
    --   (q, e) -> pw^(2*e) <= n < pw^(2*e+2)
    --              && q <= n/pw^(2*e) < (q+1)
    --              && q < pw^2
    step n pw lg =
      if n `ltInteger` pw
        then (# n, 0# #)
        else case step n (shiftLInteger pw lg) (2# *# lg) of
              (# q, e #) ->
                if q `ltInteger` pw
                  then (# q, 2# *# e #)
                  else (# q `shiftRInteger` lg, 2# *# e +# 1# #)

-- Calculate the log2 of a positive integer and check
-- whether it is a power of 2.
-- By coincidence, the presence of a power of 2 is
-- signalled by zero and not one.
integerLog2IsPowerOf2# :: Integer -> (# Int#, Int# #)
integerLog2IsPowerOf2# m =
    case integerLog2# m of
      lg -> if m `eqInteger` (smallInteger 1# `shiftLInteger` lg)
              then (# lg, 0# #)
              else (# lg, 1# #)

-- Detect the rounding mode,
-- 0# means round to zero,
-- 1# means round to even,
-- 2# means round away from zero
roundingMode# :: Integer -> Int# -> Int#
roundingMode# m h =
    case smallInteger 1# `shiftLInteger` h of
      c -> case m `andInteger`
                ((c `plusInteger` c) `minusInteger` smallInteger 1#) of
             r ->
               if c `ltInteger` r
                 then 2#
                 else if c `gtInteger` r
                        then 0#
                        else 1#

#else

default ()

-- We have a nice word size, we can do much better now.

#if WORD_SIZE_IN_BITS == 32

#define WSHIFT 5
#define MMASK 31

#else

#define WSHIFT 6
#define MMASK 63

#endif

-- Assumption: Integer is strictly positive
-- For small integers, use wordLog#,
-- in the general case, check words from the most
-- significant down, once a nonzero word is found,
-- calculate its log2 and add the number of following bits.
integerLog2# :: Integer -> Int#
integerLog2# (S# i) = wordLog2# (int2Word# i)
integerLog2# (J# s ba) = check (s -# 1#)
  where
    check i = case indexWordArray# ba i of
                0## -> check (i -# 1#)
                w   -> wordLog2# w +# (uncheckedIShiftL# i WSHIFT#)

-- Assumption: Integer is strictly positive
-- First component is log2 n, second is 0# iff n is a power of two
integerLog2IsPowerOf2# :: Integer -> (# Int#, Int# #)
-- The power of 2 test is n&(n-1) == 0, thus powers of 2
-- are indicated bythe second component being zero.
integerLog2IsPowerOf2# (S# i) =
    case int2Word# i of
      w -> (# wordLog2# w, word2Int# (w `and#` (w `minusWord#` 1##)) #)
-- Find the log2 as above, test whether that word is a power
-- of 2, if so, check whether only zero bits follow.
integerLog2IsPowerOf2# (J# s ba) = check (s -# 1#)
  where
    check :: Int# -> (# Int#, Int# #)
    check i = case indexWordArray# ba i of
                0## -> check (i -# 1#)
                w   -> (# wordLog2# w +# (uncheckedIShiftL# i WSHIFT#)
                        , case w `and#` (w `minusWord#` 1##) of
                            0## -> test (i -# 1#)
                            _   -> 1# #)
    test :: Int# -> Int#
    test i = if isTrue# (i <# 0#)
                then 0#
                else case indexWordArray# ba i of
                        0## -> test (i -# 1#)
                        _   -> 1#

-- Assumption: Integer and Int# are strictly positive, Int# is less
-- than logBase 2 of Integer, 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)
roundingMode# :: Integer -> Int# -> Int#
roundingMode# (S# i) t =
    case int2Word# i `and#` ((uncheckedShiftL# 2## t) `minusWord#` 1##) of
      k -> case uncheckedShiftL# 1## t of
            c -> if isTrue# (c `gtWord#` k)
                    then 0#
                    else if isTrue# (c `ltWord#` k)
                            then 2#
                            else 1#
roundingMode# (J# _ ba) t =
    case word2Int# (int2Word# t `and#` MMASK##) of
      j ->      -- index of relevant bit in word
        case uncheckedIShiftRA# t WSHIFT# of
          k ->  -- index of relevant word
            case indexWordArray# ba k `and#`
                    ((uncheckedShiftL# 2## j) `minusWord#` 1##) of
              r ->
                case uncheckedShiftL# 1## j of
                  c -> if isTrue# (c `gtWord#` r)
                        then 0#
                        else if isTrue# (c `ltWord#` r)
                                then 2#
                                else test (k -# 1#)
  where
    test i = if isTrue# (i <# 0#)
                then 1#
                else case indexWordArray# ba i of
                        0## -> test (i -# 1#)
                        _   -> 2#

-- 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

-- 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
