Internals.hs

-- |
-- Module:          Text.FShow.RealFloat.Internals
-- Copyright:       (c) 2011 Daniel Fischer
-- Licence:         BSD3
-- Maintainer:      Daniel Fischer <daniel.is.fischer@googlemail.com>
-- Stability:       experimental
-- Portability:     non-portable (GHC extensions)
--
-- Faster digit string generation for floating point numbers.
-- Uses a modification of the Integer showing code from "GHC.Num".
{-# LANGUAGE CPP, BangPatterns, MagicHash, UnboxedTuples #-}
{-# OPTIONS_HADDOCK hide #-}
module Text.FShow.RealFloat.Internals
    ( posToDigits
    , i2D
    ) where

#include "MachDeps.h"

import GHC.Base
import GHC.Num (quotRemInt)
import GHC.Integer
import Data.Array.Base (unsafeAt)
import Data.Array.IArray


#if WORD_SIZE_IN_BITS == 32
#define DIGITS       9
#define BASE         1000000000
#else
#define DIGITS       18
#define BASE         1000000000000000000
#endif

-- unsafe Int -> Char conversion for decimal digits
{-# INLINE i2D #-}
i2D :: Int -> Char
i2D (I# i#) = C# (chr# (ord# '0'# +# i#))

-- digits and exponent for a floating point number.
-- floatRadix is assumed to be 2, decodeFloat to return
-- a mantissa 2^(floatDigits-1) <= mantissa < 2^floatDigits
posToDigits :: Int -> Int -> Integer -> Int -> ([Int],Int)
posToDigits showDigs mantExp mant scaleExp@(I# e#) = (integerToDigits decMant, e10)
  where
    !rex = mantExp + scaleExp
    !l0 = (8651*rex) `quot` 28738
    !l10 = if rex < 0 then l0-1 else l0
    -- 10^l10 <= x < 10^(l10+2)
    !decshift@(I# d#) = showDigs - l10
    !binshift = e# +# d#
    !decMant
        | d# <# 0# =
            (if binshift <# 0#
                then shiftRInteger mant (negateInt# binshift)
                else shiftLInteger mant binshift) `quot` expt5 (I# (negateInt# d#))
        | binshift <# 0# =
            shiftRInteger (mant * expt5 decshift) (negateInt# binshift)
        | otherwise = shiftLInteger (mant * expt5 decshift) binshift
    !e10 = if decMant < expt10 (showDigs+1) then l10+1 else l10+2

expt5 :: Int -> Integer
expt5 k = if k <= maxEx5 && k >= 0 then unsafeAt expts5 k else 5^k

expt10 :: Int -> Integer
expt10 k = if k <= maxEx10 && k >= 0 then unsafeAt expts10 k else 10^k

maxEx5 :: Int
maxEx5 = 349

maxEx10 :: Int
maxEx10 = 25

expts5 :: Array Int Integer
expts5 = array (0, maxEx5) [(k,5^k) | k <- [0 .. maxEx5]]

expts10 :: Array Int Integer
expts10 = array (0,maxEx10) [(k,10^k) | k <- [0 .. maxEx10]]

------------------------------------------------------------------------------
--  The code to show Integers, modified to produce [Int] instead of [Char]
--  Taken from GHC.Num and modified to suit our needs
--  The GHC Licence is reproduced in the package root

-- Divide and conquer implementation
-- generate the sequence of digits of a positive Integer
integerToDigits :: Integer -> [Int]
integerToDigits nm
    | nm < BASE = jhead (fromInteger nm) []
    | otherwise = jprinth (jsplitf (BASE*BASE) nm) []
      where

        -- Split n into digits in base p. We first split n into digits
        -- in base p*p and then split each of these digits into two.
        -- Note that the first 'digit' modulo p*p may have a leading zero
        -- in base p that we need to drop - this is what jsplith takes care of.
        -- jsplitb the handles the remaining digits.
        jsplitf :: Integer -> Integer -> [Integer]
        jsplitf p n
            | p > n     = [n]
            | otherwise = jsplith p (jsplitf (p*p) n)

        jsplith :: Integer -> [Integer] -> [Integer]
        jsplith p (n:ns) =
            case n `quotRemInteger` p of
            (# q, r #) ->
                if q > 0 then q : r : jsplitb p ns
                        else     r : jsplitb p ns
        jsplith _ [] = error "jsplith: []"

        jsplitb :: Integer -> [Integer] -> [Integer]
        jsplitb _ []     = []
        jsplitb p (n:ns) = case n `quotRemInteger` p of
                        (# q, r #) ->
                            q : r : jsplitb p ns

        -- Convert a number that has been split into digits in base BASE^2
        -- this includes a last splitting step and then conversion of digits
        -- that all fit into a machine word.
        jprinth :: [Integer] -> [Int] -> [Int]
        jprinth (n:ns) cs =
            case n `quotRemInteger` BASE of
            (# q', r' #) ->
                let q = fromInteger q'
                    r = fromInteger r'
                in if q > 0 then jhead q $ jblock r $ jprintb ns cs
                            else jhead r $ jprintb ns cs
        jprinth [] _ = error "jprinth []"

        jprintb :: [Integer] -> [Int] -> [Int]
        jprintb []     cs = cs
        jprintb (n:ns) cs = case n `quotRemInteger` BASE of
                            (# q', r' #) ->
                                let q = fromInteger q'
                                    r = fromInteger r'
                                in jblock q $ jblock r $ jprintb ns cs

        -- Convert an integer that fits into a machine word. Again, we have two
        -- functions, one that drops leading zeros (jhead) and one that doesn't
        -- (jblock)
        jhead :: Int -> [Int] -> [Int]
        jhead n cs
            | n < 10    = n:cs
            | otherwise = jhead q (r : cs)
            where
            (q, r) = n `quotRemInt` 10

        jblock = jblock' {- ' -} DIGITS     -- bloody CPP

        jblock' :: Int -> Int -> [Int] -> [Int]
        jblock' d n cs
            | d == 1    = n : cs
            | otherwise = jblock' (d - 1) q (r : cs)
            where
            (q, r) = n `quotRemInt` 10