diff --git a/bench/Main.hs b/bench/Main.hs deleted file mode 100644 --- a/bench/Main.hs +++ /dev/null @@ -1,72 +0,0 @@ -module Main where - -import Criterion.Main -import qualified Data.Text.Encoding as Text -import qualified PtrPoker.Write as Write -import Prelude - -main :: IO () -main = - defaultMain - [ bgroup - "bWord32" - [ bench "4" - $ nf - ( \(a, b, c, d) -> - Write.writeToByteString - $ Write.bWord32 a - <> Write.bWord32 b - <> Write.bWord32 c - <> Write.bWord32 d - ) - (1, 2, 3, 4) - ], - bgroup "textUtf8" - $ let latinSampleBySize size = - enumFromTo 'a' 'z' - & replicate size - & concat - & fromString - greekSampleBySize size = - enumFromTo 'Α' 'Ω' - & replicate size - & concat - & fromString - !latinSample1 = latinSampleBySize 1 - !latinSample10 = latinSampleBySize 10 - !latinSample100 = latinSampleBySize 100 - !greekSample1 = greekSampleBySize 1 - !greekSample10 = greekSampleBySize 10 - !greekSample100 = greekSampleBySize 100 - in [ bgroup - "ptr-poker" - [ bgroup - "latin" - [ bench "1" (nf (Write.writeToByteString . Write.textUtf8) latinSample1), - bench "10" (nf (Write.writeToByteString . Write.textUtf8) latinSample10), - bench "100" (nf (Write.writeToByteString . Write.textUtf8) latinSample100) - ], - bgroup - "greek" - [ bench "1" (nf (Write.writeToByteString . Write.textUtf8) greekSample1), - bench "10" (nf (Write.writeToByteString . Write.textUtf8) greekSample10), - bench "100" (nf (Write.writeToByteString . Write.textUtf8) greekSample100) - ] - ], - bgroup - "text" - [ bgroup - "latin" - [ bench "1" (nf Text.encodeUtf8 latinSample1), - bench "10" (nf Text.encodeUtf8 latinSample10), - bench "100" (nf Text.encodeUtf8 latinSample100) - ], - bgroup - "greek" - [ bench "1" (nf Text.encodeUtf8 greekSample1), - bench "10" (nf Text.encodeUtf8 greekSample10), - bench "100" (nf Text.encodeUtf8 greekSample100) - ] - ] - ] - ] diff --git a/cbits/dtoa.c b/cbits/dtoa.c deleted file mode 100644 --- a/cbits/dtoa.c +++ /dev/null @@ -1,383 +0,0 @@ -/* -Copyright https://github.com/juj - -Licensed under the Apache License, Version 2.0 (the "License"); -you may not use this file except in compliance with the License. -You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - -Unless required by applicable law or agreed to in writing, software -distributed under the License is distributed on an "AS IS" BASIS, -WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -See the License for the specific language governing permissions and -limitations under the License. - -*/ -// modified version of https://github.com/juj/MathGeoLib/blob/master/src/Math/grisu3.c -/* This file is part of an implementation of the "grisu3" double to string - conversion algorithm described in the research paper - "Printing Floating-Point Numbers Quickly And Accurately with Integers" - by Florian Loitsch, available at - http://www.cs.tufts.edu/~nr/cs257/archive/florian-loitsch/printf.pdf */ - -#include // uint64_t etc. -#include // assert -#include // ceil -#include // sprintf - -#ifdef _MSC_VER -#pragma warning(disable : 4204) // nonstandard extension used : non-constant aggregate initializer -#endif - -#define D64_SIGN 0x8000000000000000ULL -#define D64_EXP_MASK 0x7FF0000000000000ULL -#define D64_FRACT_MASK 0x000FFFFFFFFFFFFFULL -#define D64_IMPLICIT_ONE 0x0010000000000000ULL -#define D64_EXP_POS 52 -#define D64_EXP_BIAS 1075 -#define DIYFP_FRACT_SIZE 64 -#define D_1_LOG2_10 0.30102999566398114 // 1 / lg(10) -#define MIN_TARGET_EXP -60 -#define MASK32 0xFFFFFFFFULL - -#define CAST_U64(d) (*(uint64_t*)&d) -#define MIN(x,y) ((x) <= (y) ? (x) : (y)) -#define MAX(x,y) ((x) >= (y) ? (x) : (y)) - -#define MIN_CACHED_EXP -348 -#define CACHED_EXP_STEP 8 - -typedef struct diy_fp -{ - uint64_t f; - int e; -} diy_fp; - -typedef struct power -{ - uint64_t fract; - int16_t b_exp, d_exp; -} power; - -static const power pow_cache[] = -{ - { 0xfa8fd5a0081c0288ULL, -1220, -348 }, - { 0xbaaee17fa23ebf76ULL, -1193, -340 }, - { 0x8b16fb203055ac76ULL, -1166, -332 }, - { 0xcf42894a5dce35eaULL, -1140, -324 }, - { 0x9a6bb0aa55653b2dULL, -1113, -316 }, - { 0xe61acf033d1a45dfULL, -1087, -308 }, - { 0xab70fe17c79ac6caULL, -1060, -300 }, - { 0xff77b1fcbebcdc4fULL, -1034, -292 }, - { 0xbe5691ef416bd60cULL, -1007, -284 }, - { 0x8dd01fad907ffc3cULL, -980, -276 }, - { 0xd3515c2831559a83ULL, -954, -268 }, - { 0x9d71ac8fada6c9b5ULL, -927, -260 }, - { 0xea9c227723ee8bcbULL, -901, -252 }, - { 0xaecc49914078536dULL, -874, -244 }, - { 0x823c12795db6ce57ULL, -847, -236 }, - { 0xc21094364dfb5637ULL, -821, -228 }, - { 0x9096ea6f3848984fULL, -794, -220 }, - { 0xd77485cb25823ac7ULL, -768, -212 }, - { 0xa086cfcd97bf97f4ULL, -741, -204 }, - { 0xef340a98172aace5ULL, -715, -196 }, - { 0xb23867fb2a35b28eULL, -688, -188 }, - { 0x84c8d4dfd2c63f3bULL, -661, -180 }, - { 0xc5dd44271ad3cdbaULL, -635, -172 }, - { 0x936b9fcebb25c996ULL, -608, -164 }, - { 0xdbac6c247d62a584ULL, -582, -156 }, - { 0xa3ab66580d5fdaf6ULL, -555, -148 }, - { 0xf3e2f893dec3f126ULL, -529, -140 }, - { 0xb5b5ada8aaff80b8ULL, -502, -132 }, - { 0x87625f056c7c4a8bULL, -475, -124 }, - { 0xc9bcff6034c13053ULL, -449, -116 }, - { 0x964e858c91ba2655ULL, -422, -108 }, - { 0xdff9772470297ebdULL, -396, -100 }, - { 0xa6dfbd9fb8e5b88fULL, -369, -92 }, - { 0xf8a95fcf88747d94ULL, -343, -84 }, - { 0xb94470938fa89bcfULL, -316, -76 }, - { 0x8a08f0f8bf0f156bULL, -289, -68 }, - { 0xcdb02555653131b6ULL, -263, -60 }, - { 0x993fe2c6d07b7facULL, -236, -52 }, - { 0xe45c10c42a2b3b06ULL, -210, -44 }, - { 0xaa242499697392d3ULL, -183, -36 }, - { 0xfd87b5f28300ca0eULL, -157, -28 }, - { 0xbce5086492111aebULL, -130, -20 }, - { 0x8cbccc096f5088ccULL, -103, -12 }, - { 0xd1b71758e219652cULL, -77, -4 }, - { 0x9c40000000000000ULL, -50, 4 }, - { 0xe8d4a51000000000ULL, -24, 12 }, - { 0xad78ebc5ac620000ULL, 3, 20 }, - { 0x813f3978f8940984ULL, 30, 28 }, - { 0xc097ce7bc90715b3ULL, 56, 36 }, - { 0x8f7e32ce7bea5c70ULL, 83, 44 }, - { 0xd5d238a4abe98068ULL, 109, 52 }, - { 0x9f4f2726179a2245ULL, 136, 60 }, - { 0xed63a231d4c4fb27ULL, 162, 68 }, - { 0xb0de65388cc8ada8ULL, 189, 76 }, - { 0x83c7088e1aab65dbULL, 216, 84 }, - { 0xc45d1df942711d9aULL, 242, 92 }, - { 0x924d692ca61be758ULL, 269, 100 }, - { 0xda01ee641a708deaULL, 295, 108 }, - { 0xa26da3999aef774aULL, 322, 116 }, - { 0xf209787bb47d6b85ULL, 348, 124 }, - { 0xb454e4a179dd1877ULL, 375, 132 }, - { 0x865b86925b9bc5c2ULL, 402, 140 }, - { 0xc83553c5c8965d3dULL, 428, 148 }, - { 0x952ab45cfa97a0b3ULL, 455, 156 }, - { 0xde469fbd99a05fe3ULL, 481, 164 }, - { 0xa59bc234db398c25ULL, 508, 172 }, - { 0xf6c69a72a3989f5cULL, 534, 180 }, - { 0xb7dcbf5354e9beceULL, 561, 188 }, - { 0x88fcf317f22241e2ULL, 588, 196 }, - { 0xcc20ce9bd35c78a5ULL, 614, 204 }, - { 0x98165af37b2153dfULL, 641, 212 }, - { 0xe2a0b5dc971f303aULL, 667, 220 }, - { 0xa8d9d1535ce3b396ULL, 694, 228 }, - { 0xfb9b7cd9a4a7443cULL, 720, 236 }, - { 0xbb764c4ca7a44410ULL, 747, 244 }, - { 0x8bab8eefb6409c1aULL, 774, 252 }, - { 0xd01fef10a657842cULL, 800, 260 }, - { 0x9b10a4e5e9913129ULL, 827, 268 }, - { 0xe7109bfba19c0c9dULL, 853, 276 }, - { 0xac2820d9623bf429ULL, 880, 284 }, - { 0x80444b5e7aa7cf85ULL, 907, 292 }, - { 0xbf21e44003acdd2dULL, 933, 300 }, - { 0x8e679c2f5e44ff8fULL, 960, 308 }, - { 0xd433179d9c8cb841ULL, 986, 316 }, - { 0x9e19db92b4e31ba9ULL, 1013, 324 }, - { 0xeb96bf6ebadf77d9ULL, 1039, 332 }, - { 0xaf87023b9bf0ee6bULL, 1066, 340 } -}; - -static int cached_pow(int exp, diy_fp *p) -{ - int k = (int)ceil((exp+DIYFP_FRACT_SIZE-1) * D_1_LOG2_10); - int i = (k-MIN_CACHED_EXP-1) / CACHED_EXP_STEP + 1; - p->f = pow_cache[i].fract; - p->e = pow_cache[i].b_exp; - return pow_cache[i].d_exp; -} - -static diy_fp minus(diy_fp x, diy_fp y) -{ - diy_fp d; d.f = x.f - y.f; d.e = x.e; - assert(x.e == y.e && x.f >= y.f); - return d; -} - -static diy_fp multiply(diy_fp x, diy_fp y) -{ - uint64_t a, b, c, d, ac, bc, ad, bd, tmp; - diy_fp r; - a = x.f >> 32; b = x.f & MASK32; - c = y.f >> 32; d = y.f & MASK32; - ac = a*c; bc = b*c; - ad = a*d; bd = b*d; - tmp = (bd >> 32) + (ad & MASK32) + (bc & MASK32); - tmp += 1U << 31; // round - r.f = ac + (ad >> 32) + (bc >> 32) + (tmp >> 32); - r.e = x.e + y.e + 64; - return r; -} - -static diy_fp normalize_diy_fp(diy_fp n) -{ - assert(n.f != 0); - while(!(n.f & 0xFFC0000000000000ULL)) { n.f <<= 10; n.e -= 10; } - while(!(n.f & D64_SIGN)) { n.f <<= 1; --n.e; } - return n; -} - -static diy_fp double2diy_fp(double d) -{ - diy_fp fp; - uint64_t u64 = CAST_U64(d); - if (!(u64 & D64_EXP_MASK)) { fp.f = u64 & D64_FRACT_MASK; fp.e = 1 - D64_EXP_BIAS; } - else { fp.f = (u64 & D64_FRACT_MASK) + D64_IMPLICIT_ONE; fp.e = (int)((u64 & D64_EXP_MASK) >> D64_EXP_POS) - D64_EXP_BIAS; } - return fp; -} - -// pow10_cache[i] = 10^(i-1) -static const unsigned int pow10_cache[] = { 0, 1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000 }; - -static int largest_pow10(uint32_t n, int n_bits, uint32_t *power) -{ - int guess = ((n_bits + 1) * 1233 >> 12) + 1/*skip first entry*/; - if (n < pow10_cache[guess]) --guess; // We don't have any guarantees that 2^n_bits <= n. - *power = pow10_cache[guess]; - return guess; -} - -static int round_weed(char *buffer, int len, uint64_t wp_W, uint64_t delta, uint64_t rest, uint64_t ten_kappa, uint64_t ulp) -{ - uint64_t wp_Wup = wp_W - ulp; - uint64_t wp_Wdown = wp_W + ulp; - while(rest < wp_Wup && delta - rest >= ten_kappa - && (rest + ten_kappa < wp_Wup || wp_Wup - rest >= rest + ten_kappa - wp_Wup)) - { - --buffer[len-1]; - rest += ten_kappa; - } - if (rest < wp_Wdown && delta - rest >= ten_kappa - && (rest + ten_kappa < wp_Wdown || wp_Wdown - rest > rest + ten_kappa - wp_Wdown)) - return 0; - - return 2*ulp <= rest && rest <= delta - 4*ulp; -} - -static int digit_gen(diy_fp low, diy_fp w, diy_fp high, char *buffer, int *length, int *kappa) -{ - uint64_t unit = 1; - diy_fp too_low = { low.f - unit, low.e }; - diy_fp too_high = { high.f + unit, high.e }; - diy_fp unsafe_interval = minus(too_high, too_low); - diy_fp one = { 1ULL << -w.e, w.e }; - uint32_t p1 = (uint32_t)(too_high.f >> -one.e); - uint64_t p2 = too_high.f & (one.f - 1); - uint32_t div; - *kappa = largest_pow10(p1, DIYFP_FRACT_SIZE + one.e, &div); - *length = 0; - - while(*kappa > 0) - { - uint64_t rest; - int digit = p1 / div; - buffer[*length] = (char)('0' + digit); - ++*length; - p1 %= div; - --*kappa; - rest = ((uint64_t)p1 << -one.e) + p2; - if (rest < unsafe_interval.f) return round_weed(buffer, *length, minus(too_high, w).f, unsafe_interval.f, rest, (uint64_t)div << -one.e, unit); - div /= 10; - } - - for(;;) - { - int digit; - p2 *= 10; - unit *= 10; - unsafe_interval.f *= 10; - // Integer division by one. - digit = (int)(p2 >> -one.e); - buffer[*length] = (char)('0' + digit); - ++*length; - p2 &= one.f - 1; // Modulo by one. - --*kappa; - if (p2 < unsafe_interval.f) return round_weed(buffer, *length, minus(too_high, w).f * unit, unsafe_interval.f, p2, one.f, unit); - } -} - -int grisu3(double v, char *buffer, int *length, int *d_exp) -{ - int mk, kappa, success; - diy_fp dfp = double2diy_fp(v); - diy_fp w = normalize_diy_fp(dfp); - - // normalize boundaries - diy_fp t = { (dfp.f << 1) + 1, dfp.e - 1 }; - diy_fp b_plus = normalize_diy_fp(t); - diy_fp b_minus; - diy_fp c_mk; // Cached power of ten: 10^-k - uint64_t u64 = CAST_U64(v); - assert(v > 0 && v <= 1.7976931348623157e308); // Grisu only handles strictly positive finite numbers. - if (!(u64 & D64_FRACT_MASK) && (u64 & D64_EXP_MASK) != 0) { b_minus.f = (dfp.f << 2) - 1; b_minus.e = dfp.e - 2;} // lower boundary is closer? - else { b_minus.f = (dfp.f << 1) - 1; b_minus.e = dfp.e - 1; } - b_minus.f = b_minus.f << (b_minus.e - b_plus.e); - b_minus.e = b_plus.e; - - mk = cached_pow(MIN_TARGET_EXP - DIYFP_FRACT_SIZE - w.e, &c_mk); - - w = multiply(w, c_mk); - b_minus = multiply(b_minus, c_mk); - b_plus = multiply(b_plus, c_mk); - - success = digit_gen(b_minus, w, b_plus, buffer, length, &kappa); - *d_exp = kappa - mk; - return success; -} - -static int i_to_str(int val, char *str) -{ - int len, i; - char *s; - char *begin = str; - if (val < 0) { *str++ = '-'; val = -val; } - s = str; - - for(;;) - { - int ni = val / 10; - int digit = val - ni*10; - *s++ = (char)('0' + digit); - if (ni == 0) - break; - val = ni; - } - *s = '\0'; - len = (int)(s - str); - for(i = 0; i < len/2; ++i) - { - char ch = str[i]; - str[i] = str[len-1-i]; - str[len-1-i] = ch; - } - - return (int)(s - begin); -} - -int dtoa_grisu3(double v, char *dst) -{ - int d_exp, len, decimals, i; - - int success = grisu3(v, dst, &len, &d_exp); - // If grisu3 was not able to convert the number to a string, then use old sprintf (suboptimal). - if (!success) return sprintf(dst, "%.17g", v) + (int)(dst - dst); - - // We now have an integer string of form "151324135" and a base-10 exponent for that number. - // Next, decide the best presentation for that string by whether to use a decimal point, or the scientific exponent notation 'e'. - // We don't pick the absolute shortest representation, but pick a balance between readability and shortness, e.g. - // 1.545056189557677e-308 could be represented in a shorter form - // 1545056189557677e-323 but that would be somewhat unreadable. - decimals = MIN(-d_exp, MAX(1, len-1)); - if (d_exp < 0 && len > 1) // Add decimal point? - { - int dot_pos = len-decimals; - if (dot_pos == 0) { - for(i = 0; i < decimals; ++i) { - dst[len-i+1] = dst[len-i-1]; - } - // put a 0 in front of the decimal point to make it a valid Haskell floating point number. - dst[0] = '0'; - dst[1] = '.'; - len+= 2; - } else { - for(i = 0; i < decimals; ++i) { - dst[len-i] = dst[len-i-1]; - } - dst[dot_pos] = '.'; - len++; - } - - d_exp += decimals; - // Need scientific notation as well? - if (d_exp != 0) { dst[len++] = 'e'; len += i_to_str(d_exp, dst+len); } - } - else if (d_exp < 0 && d_exp >= -3) // Add decimal point for numbers of form 0.000x where it's shorter? - { - // len here is 1! - dst[1-d_exp] = dst[0]; - // put a 0 in front of the decimal point to make it a valid Haskell floating point number. - dst[0] = '0'; - dst[1] = '.'; - for(i = 2; i < (1-d_exp); ++i) dst[i] = '0'; - len += -d_exp+1; - } - // Add scientific notation? - else if (d_exp < 0 || d_exp > 2) { dst[len++] = 'e'; len += i_to_str(d_exp, dst+len); } - // Add zeroes instead of scientific notation? - else if (d_exp > 0) { while(d_exp-- > 0) dst[len++] = '0'; } - // dst[len] = '\0'; // grisu3 doesn't null terminate, so ensure termination. - return (int)(dst+len-dst); -} diff --git a/cbits/int_encoding.c b/cbits/int_encoding.c deleted file mode 100644 --- a/cbits/int_encoding.c +++ /dev/null @@ -1,65 +0,0 @@ -/* - * Copyright (c) 2020 Nikita Volkov . - */ - -#include -#include -#include -#include -#include - - -void rev_poke_int64 -( - int64_t val, - uint8_t* dst -) -{ - bool negate = false; - - if (val < 0) - { - int64_t b4 = val; - val /= 10; - if (val) - { - *--dst = val * 10 - b4 + 48; - val = -val; - negate = true; - } - else - { - *(dst - 1) = val * 10 - b4 + 48; - *(dst - 2) = '-'; - return; - } - } - - do - { - int64_t b4 = val; - val /= 10; - *--dst = b4 - val * 10 + 48; - } - while (val); - - if (negate) - { - *--dst = '-'; - } -} - -void rev_poke_uint64 -( - uint64_t val, - uint8_t* dst -) -{ - do - { - uint64_t b4 = val; - val /= 10; - *--dst = b4 - val * 10 + 48; - } - while (val); -} diff --git a/cbits/itoa.c b/cbits/itoa.c deleted file mode 100644 --- a/cbits/itoa.c +++ /dev/null @@ -1,216 +0,0 @@ -/////////////////////////////////////////////////////////////// -// Encoding numbers using ASCII characters // -// // -// inspired by: http://www.jb.man.ac.uk/~slowe/cpp/itoa.html // -// Borrowed from the "bytestring" library // -/////////////////////////////////////////////////////////////// - -#include - -// Decimal Encoding -/////////////////// - -static const char* digits = "0123456789abcdef"; - -// signed integers -char* int_dec (int x, char* buf) -{ - char c, *ptr = buf, *next_free; - int x_tmp; - - // we cannot negate directly as 0 - (minBound :: Int) = minBound - if (x < 0) { - *ptr++ = '-'; - buf++; - x_tmp = x; - x /= 10; - *ptr++ = digits[x * 10 - x_tmp]; - if (x == 0) - return ptr; - else - x = -x; - } - - // encode positive number as little-endian decimal - do { - x_tmp = x; - x /= 10; - *ptr++ = digits[x_tmp - x * 10]; - } while ( x ); - - // reverse written digits - next_free = ptr--; - while (buf < ptr) { - c = *ptr; - *ptr-- = *buf; - *buf++ = c; - } - return next_free; -} - -// signed long long ints (64 bit integers) -char* long_long_int_dec (long long int x, char* buf) -{ - char c, *ptr = buf, *next_free; - long long int x_tmp; - - // we cannot negate directly as 0 - (minBound :: Int) = minBound - if (x < 0) { - *ptr++ = '-'; - buf++; - x_tmp = x; - x /= 10; - *ptr++ = digits[x * 10 - x_tmp]; - if (x == 0) - return ptr; - else - x = -x; - } - - // encode positive number as little-endian decimal - do { - x_tmp = x; - x /= 10; - *ptr++ = digits[x_tmp - x * 10]; - } while ( x ); - - // reverse written digits - next_free = ptr--; - while (buf < ptr) { - c = *ptr; - *ptr-- = *buf; - *buf++ = c; - } - return next_free; -} - -// unsigned integers -char* uint_dec (unsigned int x, char* buf) -{ - char c, *ptr = buf, *next_free; - unsigned int x_tmp; - - // encode positive number as little-endian decimal - do { - x_tmp = x; - x /= 10; - *ptr++ = digits[x_tmp - x * 10]; - } while ( x ); - - // reverse written digits - next_free = ptr--; - while (buf < ptr) { - c = *ptr; - *ptr-- = *buf; - *buf++ = c; - } - return next_free; -} - -// unsigned long ints -char* long_long_uint_dec (long long unsigned int x, char* buf) -{ - char c, *ptr = buf, *next_free; - long long unsigned int x_tmp; - - // encode positive number as little-endian decimal - do { - x_tmp = x; - x /= 10; - *ptr++ = digits[x_tmp - x * 10]; - } while ( x ); - - // reverse written digits - next_free = ptr--; - while (buf < ptr) { - c = *ptr; - *ptr-- = *buf; - *buf++ = c; - } - return next_free; -} - - -// Padded, decimal, positive integers for the decimal output of bignums -/////////////////////////////////////////////////////////////////////// - -// Padded (9 digits), decimal, positive int: -// We will use it with numbers that fit in 31 bits; i.e., numbers smaller than -// 10^9, as "31 * log 2 / log 10 = 9.33" -void int_dec_padded9 (int x, char* buf) -{ - const int max_width_int32_dec = 9; - char* ptr = buf + max_width_int32_dec; - int x_tmp; - - // encode positive number as little-endian decimal - do { - x_tmp = x; - x /= 10; - *(--ptr) = digits[x_tmp - x * 10]; - } while ( x ); - - // pad beginning - while (buf < ptr) { *(--ptr) = '0'; } -} - -// Padded (19 digits), decimal, positive long long int: -// We will use it with numbers that fit in 63 bits; i.e., numbers smaller than -// 10^18, as "63 * log 2 / log 10 = 18.96" -void long_long_int_dec_padded18 (long long int x, char* buf) -{ - const int max_width_int64_dec = 18; - char* ptr = buf + max_width_int64_dec; - long long int x_tmp; - - // encode positive number as little-endian decimal - do { - x_tmp = x; - x /= 10; - *(--ptr) = digits[x_tmp - x * 10]; - } while ( x ); - - // pad beginning - while (buf < ptr) { *(--ptr) = '0'; } -} - - -/////////////////////// -// Hexadecimal encoding -/////////////////////// - -// unsigned ints (32 bit words) -char* uint_hex (unsigned int x, char* buf) { - // write hex representation in reverse order - char c, *ptr = buf, *next_free; - do { - *ptr++ = digits[x & 0xf]; - x >>= 4; - } while ( x ); - // invert written digits - next_free = ptr--; - while(buf < ptr) { - c = *ptr; - *ptr-- = *buf; - *buf++ = c; - } - return next_free; -}; - -// unsigned long ints (64 bit words) -char* long_long_uint_hex (long long unsigned int x, char* buf) { - // write hex representation in reverse order - char c, *ptr = buf, *next_free; - do { - *ptr++ = digits[x & 0xf]; - x >>= 4; - } while ( x ); - // invert written digits - next_free = ptr--; - while(buf < ptr) { - c = *ptr; - *ptr-- = *buf; - *buf++ = c; - } - return next_free; -}; diff --git a/cbits/text.c b/cbits/text.c deleted file mode 100644 --- a/cbits/text.c +++ /dev/null @@ -1,232 +0,0 @@ -/* - * Copyright (c) 2020 Nikita Volkov . - * - * Portions copyright (c) 2011 Bryan O'Sullivan . - * - * Portions copyright (c) 2008-2010 Björn Höhrmann . - * - * See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details. - */ - -#include -#include -#include -#include - - -uint8_t* encode_text -( - uint8_t *dest, - const uint16_t *src, - size_t src_offset, - size_t src_length -) -#if defined(__x86_64__) -{ - - src += src_offset; - - const uint16_t* src_end = src + src_length; - const uint16_t* full_word_src_end = src_end - 4; - - while (src < src_end) { - uint16_t x = *src++; - - if (x <= 0x7F) { - *dest++ = x; - - while (src < full_word_src_end) { - uint64_t x = *((uint64_t *) src); - - if (x & 0xFF80FF80FF80FF80ULL) { - if (!(x & 0x000000000000FF80ULL)) { - *dest++ = x & 0xFFFF; - src++; - if (!(x & 0x00000000FF800000ULL)) { - *dest++ = (x >> 16) & 0xFFFF; - src++; - if (!(x & 0x0000FF8000000000ULL)) { - *dest++ = (x >> 32) & 0xFFFF; - src++; - } - } - } - break; - } - - *dest++ = x & 0xFFFF; - *dest++ = (x >> 16) & 0xFFFF; - *dest++ = (x >> 32) & 0xFFFF; - *dest++ = x >> 48; - src += 4; - } - } - else if (x <= 0x7FF) { - *dest++ = (x >> 6) | 0xC0; - *dest++ = (x & 0x3f) | 0x80; - } - else if (x < 0xD800 || x > 0xDBFF) { - *dest++ = (x >> 12) | 0xE0; - *dest++ = ((x >> 6) & 0x3F) | 0x80; - *dest++ = (x & 0x3F) | 0x80; - } else { - uint32_t c = - ((((uint32_t) x) - 0xD800) << 10) + - (((uint32_t) *src++) - 0xDC00) + 0x10000; - *dest++ = (c >> 18) | 0xF0; - *dest++ = ((c >> 12) & 0x3F) | 0x80; - *dest++ = ((c >> 6) & 0x3F) | 0x80; - *dest++ = (c & 0x3F) | 0x80; - } - } - - return dest; -} -#else -{ - - src += src_offset; - - const uint16_t* src_end = src + src_length; - const uint16_t* full_word_src_end = src_end - 2; - - while (src < src_end) { - uint16_t x = *src++; - - if (x <= 0x7F) { - *dest++ = x; - - while (src < full_word_src_end) { - uint32_t x = *((uint32_t *) src); - - if (x & 0xFF80FF80) - break; - *dest++ = x & 0xFFFF; - *dest++ = x >> 16; - src += 2; - } - - } - else if (x <= 0x7FF) { - *dest++ = (x >> 6) | 0xC0; - *dest++ = (x & 0x3f) | 0x80; - } - else if (x < 0xD800 || x > 0xDBFF) { - *dest++ = (x >> 12) | 0xE0; - *dest++ = ((x >> 6) & 0x3F) | 0x80; - *dest++ = (x & 0x3F) | 0x80; - } else { - uint32_t c = - ((((uint32_t) x) - 0xD800) << 10) + - (((uint32_t) *src++) - 0xDC00) + 0x10000; - *dest++ = (c >> 18) | 0xF0; - *dest++ = ((c >> 12) & 0x3F) | 0x80; - *dest++ = ((c >> 6) & 0x3F) | 0x80; - *dest++ = (c & 0x3F) | 0x80; - } - } - - return dest; -} -#endif - - -int count_text_allocation_size -( - const uint16_t *src_ptr, - size_t src_off, - size_t src_len -) -#if defined(__x86_64__) -{ - src_ptr += src_off; - - const uint16_t* after_src_ptr = src_ptr + src_len; - const uint16_t* full_word_after_src_ptr = after_src_ptr - 4; - - size_t size = 0; - - while (src_ptr < after_src_ptr) { - uint16_t w = *src_ptr++; - - if (w <= 0x7F) { - size += 1; - - /* Try to go in batches of 4 bytes. */ - while (src_ptr < full_word_after_src_ptr) { - uint64_t x = *((uint64_t*) src_ptr); - - if (x & 0xFF80FF80FF80FF80ULL) { - if (!(x & 0x000000000000FF80ULL)) { - size++; - src_ptr++; - if (!(x & 0x00000000FF800000ULL)) { - size++; - src_ptr++; - if (!(x & 0x0000FF8000000000ULL)) { - size++; - src_ptr++; - } - } - } - break; - } - - size += 4; - src_ptr += 4; - } - - } - else if (w <= 0x7FF) { - size += 2; - } - else if (w < 0xD800 || w > 0xDBFF) { - size += 3; - } else { - src_ptr++; - size += 4; - } - } - - return size; -} -#else -{ - src_ptr += src_off; - - const uint16_t* after_src_ptr = src_ptr + src_len; - const uint16_t* full_word_after_src_ptr = after_src_ptr - 2; - - size_t size = 0; - - while (src_ptr < after_src_ptr) { - uint16_t w = *src_ptr++; - - if (w <= 0x7F) { - size += 1; - - /* Try to go in batches of 2 bytes. */ - while (src_ptr < full_word_after_src_ptr) { - uint32_t x = *((uint32_t *) src_ptr); - - if (x & 0xFF80FF80) break; - - size += 2; - src_ptr += 2; - } - - } - else if (w <= 0x7FF) { - size += 2; - } - else if (w < 0xD800 || w > 0xDBFF) { - size += 3; - } else { - src_ptr++; - size += 4; - } - } - - return size; -} -#endif diff --git a/library/PtrPoker/ByteString.hs b/library/PtrPoker/ByteString.hs deleted file mode 100644 --- a/library/PtrPoker/ByteString.hs +++ /dev/null @@ -1,43 +0,0 @@ -module PtrPoker.ByteString where - -import Data.ByteString -import qualified Data.ByteString.Builder as Builder -import qualified Data.ByteString.Builder.Extra as Builder -import qualified Data.ByteString.Builder.Scientific as ScientificBuilder -import Data.ByteString.Internal -import qualified Data.ByteString.Lazy as Lazy -import qualified PtrPoker.Compat.Text as TextCompat -import qualified PtrPoker.Ffi as Ffi -import PtrPoker.Prelude hiding (empty) - -builderWithStrategy :: Builder.AllocationStrategy -> Builder.Builder -> ByteString -builderWithStrategy strategy builder = - builder - & Builder.toLazyByteStringWith strategy Lazy.empty - & Lazy.toStrict - -scientific :: Scientific -> ByteString -scientific sci = - sci - & ScientificBuilder.scientificBuilder - & builderWithStrategy (Builder.untrimmedStrategy 128 128) - -double :: Double -> ByteString -double dbl = - unsafeCreateUptoN - 25 - ( \ptr -> - Ffi.pokeDouble dbl ptr - & fmap fromIntegral - ) - -unsafeCreateDownToN :: Int -> (Ptr Word8 -> IO Int) -> ByteString -unsafeCreateDownToN allocSize populate = - unsafeDupablePerformIO $ do - fp <- mallocByteString allocSize - actualSize <- withForeignPtr fp (\p -> populate (plusPtr p (pred allocSize))) - return $! PS fp (allocSize - actualSize) actualSize - -{-# INLINE textUtf8 #-} -textUtf8 :: Text -> ByteString -textUtf8 = TextCompat.encodeInUtf8 diff --git a/library/PtrPoker/Compat/ByteString.hs b/library/PtrPoker/Compat/ByteString.hs deleted file mode 100644 --- a/library/PtrPoker/Compat/ByteString.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE CPP #-} - -module PtrPoker.Compat.ByteString (poke) where - -import Data.ByteString.Internal -import Foreign.Marshal.Utils -import qualified PtrPoker.Compat.ForeignPtr as ForeignPtr -import PtrPoker.Prelude hiding (poke) - -{-# INLINE poke #-} -poke :: ByteString -> Ptr Word8 -> IO (Ptr Word8) - -#if MIN_VERSION_bytestring(0,11,0) - -poke (BS fptr length) ptr = - {-# SCC "poke" #-} - ForeignPtr.unsafeWithForeignPtr fptr $ \ bytesPtr -> - copyBytes ptr bytesPtr length $> - plusPtr ptr length - -#else - -poke (PS fptr offset length) ptr = - {-# SCC "poke" #-} - ForeignPtr.unsafeWithForeignPtr fptr $ \ bytesPtr -> - copyBytes ptr (plusPtr bytesPtr offset) length $> - plusPtr ptr length - -#endif diff --git a/library/PtrPoker/Compat/ForeignPtr.hs b/library/PtrPoker/Compat/ForeignPtr.hs deleted file mode 100644 --- a/library/PtrPoker/Compat/ForeignPtr.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE CPP #-} - -module PtrPoker.Compat.ForeignPtr where - -import PtrPoker.Prelude - -#if MIN_VERSION_base(4,15,0) -import qualified GHC.ForeignPtr -#else -import qualified Foreign.ForeignPtr -#endif - --- | 'unsafeWithForeignPtr' compatibility wrapper. --- --- GHC 9.0 made 'withForeignPtr' sound at the cost of performance. If you want to --- use the faster unsafe implementation, it's now at 'unsafeWithForeignPtr', and --- GHC asks you to promise that your continuation does not diverge. All we do here --- is @memcpy@ bytestrings, so we gladly pinky swear. For more detail, see Ben --- Gamari's post: --- --- --- Note that fumieval's mason uses 'unsafeWithForeignPtr' in the same way also to --- copy bytestrings. -{-# INLINE unsafeWithForeignPtr #-} -unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b -#if MIN_VERSION_base(4,15,0) -unsafeWithForeignPtr = - GHC.ForeignPtr.unsafeWithForeignPtr -#else -unsafeWithForeignPtr = - -- same implementation as new @unsafeWithForeignPtr@ (it was always unsafe) - Foreign.ForeignPtr.withForeignPtr -#endif diff --git a/library/PtrPoker/Compat/Text.hs b/library/PtrPoker/Compat/Text.hs deleted file mode 100644 --- a/library/PtrPoker/Compat/Text.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE CPP #-} - -module PtrPoker.Compat.Text where - -#if MIN_VERSION_text(2,0,0) -import qualified Data.Text.Array as TextArray -import qualified Data.Text.Encoding as TextEncoding -import qualified Data.Text.Internal as TextInternal -import PtrPoker.Prelude - -{-# INLINE destruct #-} -destruct :: (ByteArray# -> Int -> Int -> x) -> Text -> x -destruct k (TextInternal.Text (TextArray.ByteArray arr) off len) = k arr off len - -{-# INLINE utf8EncodingSize #-} -utf8EncodingSize :: Text -> Int -utf8EncodingSize = destruct $ \_arr _off len -> len - -{-# INLINEABLE encodeInUtf8 #-} -encodeInUtf8 :: Text -> ByteString -encodeInUtf8 t = TextEncoding.encodeUtf8 t - -{-# INLINE pokeInUtf8 #-} -pokeInUtf8 :: Text -> Ptr Word8 -> IO (Ptr Word8) -pokeInUtf8 (TextInternal.Text arr off len) p = - stToIO (TextArray.copyToPointer arr off p len) $> plusPtr p len -#else -import qualified Data.ByteString.Internal as ByteStringInternal -import qualified Data.Text.Array as TextArray -import qualified Data.Text.Internal as TextInternal -import qualified PtrPoker.Ffi as Ffi -import PtrPoker.Prelude - -{-# INLINE destruct #-} -destruct :: (ByteArray# -> Int -> Int -> x) -> Text -> x -destruct k (TextInternal.Text (TextArray.Array arr) off len) = - k arr off len - -{-# INLINEABLE utf8EncodingSize #-} -utf8EncodingSize :: Text -> Int -utf8EncodingSize (TextInternal.Text (TextArray.Array arr) off len) = - Ffi.countTextAllocationSize - arr - (fromIntegral off) - (fromIntegral len) - & unsafeDupablePerformIO - & fromIntegral - -{-# INLINEABLE encodeInUtf8 #-} -encodeInUtf8 :: Text -> ByteString -encodeInUtf8 (TextInternal.Text (TextArray.Array arr) off len) = - if len == 0 - then mempty - else ByteStringInternal.unsafeCreateUptoN (len * 3) $ \ptr -> do - postPtr <- inline Ffi.encodeText ptr arr (fromIntegral off) (fromIntegral len) - return (minusPtr postPtr ptr) - -{-# INLINE pokeInUtf8 #-} -pokeInUtf8 :: Text -> Ptr Word8 -> IO (Ptr Word8) -pokeInUtf8 (TextInternal.Text (TextArray.Array arr) off len) p = - Ffi.encodeText p arr (fromIntegral off) (fromIntegral len) -#endif diff --git a/library/PtrPoker/Ffi.hs b/library/PtrPoker/Ffi.hs deleted file mode 100644 --- a/library/PtrPoker/Ffi.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE UnliftedFFITypes #-} - -module PtrPoker.Ffi where - -import Foreign.C -import PtrPoker.Prelude - -foreign import ccall unsafe "static int_dec" - pokeIntInDec :: CInt -> Ptr Word8 -> IO (Ptr Word8) - -foreign import ccall unsafe "static long_long_int_dec" - pokeLongLongIntInDec :: CLLong -> Ptr Word8 -> IO (Ptr Word8) - -foreign import ccall unsafe "static uint_dec" - pokeUIntInDec :: CUInt -> Ptr Word8 -> IO (Ptr Word8) - -foreign import ccall unsafe "static long_long_uint_dec" - pokeLongLongUIntInDec :: CULLong -> Ptr Word8 -> IO (Ptr Word8) - -foreign import ccall unsafe "static uint_hex" - pokeUIntInHex :: CUInt -> Ptr Word8 -> IO (Ptr Word8) - -foreign import ccall unsafe "static long_long_uint_hex" - pokeLongLongUIntInHex :: CULLong -> Ptr Word8 -> IO (Ptr Word8) - -foreign import ccall unsafe "static rev_poke_int64" - revPokeInt64 :: CLLong -> Ptr Word8 -> IO () - -foreign import ccall unsafe "static rev_poke_uint64" - revPokeUInt64 :: CULLong -> Ptr Word8 -> IO () - -foreign import ccall unsafe "static dtoa_grisu3" - pokeDouble :: Double -> Ptr Word8 -> IO CInt - -foreign import ccall unsafe "static count_text_allocation_size" - countTextAllocationSize :: ByteArray# -> CSize -> CSize -> IO CInt - -foreign import ccall unsafe "static encode_text" - encodeText :: Ptr Word8 -> ByteArray# -> CSize -> CSize -> IO (Ptr Word8) diff --git a/library/PtrPoker/IO/Prim.hs b/library/PtrPoker/IO/Prim.hs deleted file mode 100644 --- a/library/PtrPoker/IO/Prim.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE CPP #-} - -module PtrPoker.IO.Prim where - -import PtrPoker.Prelude - -{-# INLINE pokeStorable #-} -pokeStorable :: (Storable a) => Ptr Word8 -> a -> IO () -pokeStorable ptr value = - {-# SCC "pokeStorable" #-} - poke (castPtr ptr) value - -{-# INLINE pokeWord8 #-} -pokeWord8 :: Ptr Word8 -> Word8 -> IO () -pokeWord8 ptr value = - {-# SCC "pokeWord8" #-} - poke ptr value - -{-# INLINE pokeWord8Off #-} -pokeWord8Off :: Ptr Word8 -> Int -> Word8 -> IO () -pokeWord8Off ptr off value = - {-# SCC "pokeWord8Off" #-} - pokeByteOff ptr off value - -{-# INLINE pokeBEWord16 #-} -pokeBEWord16 :: Ptr Word8 -> Word16 -> IO () -#ifdef WORDS_BIGENDIAN -pokeBEWord16 = - {-# SCC "pokeBEWord16" #-} - pokeStorable -#else -pokeBEWord16 ptr = - {-# SCC "pokeBEWord16" #-} - pokeStorable ptr . byteSwap16 -#endif - -{-# INLINE pokeBEWord32 #-} -pokeBEWord32 :: Ptr Word8 -> Word32 -> IO () -#ifdef WORDS_BIGENDIAN -pokeBEWord32 = - {-# SCC "pokeBEWord32" #-} - pokeStorable -#else -pokeBEWord32 ptr = - {-# SCC "pokeBEWord32" #-} - pokeStorable ptr . byteSwap32 -#endif - -{-# INLINE pokeBEWord64 #-} -pokeBEWord64 :: Ptr Word8 -> Word64 -> IO () -#ifdef WORDS_BIGENDIAN -pokeBEWord64 = - {-# SCC "pokeBEWord64" #-} - pokeStorable -#else -pokeBEWord64 ptr = - {-# SCC "pokeBEWord64" #-} - pokeStorable ptr . byteSwap64 -#endif - -{-# INLINE pokeLEWord16 #-} -pokeLEWord16 :: Ptr Word8 -> Word16 -> IO () -#ifdef WORDS_BIGENDIAN -pokeLEWord16 ptr = - {-# SCC "pokeLEWord16" #-} - pokeStorable ptr . byteSwap16 -#else -pokeLEWord16 = - {-# SCC "pokeLEWord16" #-} - pokeStorable -#endif - -{-# INLINE pokeLEWord32 #-} -pokeLEWord32 :: Ptr Word8 -> Word32 -> IO () -#ifdef WORDS_BIGENDIAN -pokeLEWord32 ptr = - {-# SCC "pokeLEWord32" #-} - pokeStorable ptr . byteSwap32 -#else -pokeLEWord32 = - {-# SCC "pokeLEWord32" #-} - pokeStorable -#endif - -{-# INLINE pokeLEWord64 #-} -pokeLEWord64 :: Ptr Word8 -> Word64 -> IO () -#ifdef WORDS_BIGENDIAN -pokeLEWord64 ptr = - {-# SCC "pokeLEWord64" #-} - pokeStorable ptr . byteSwap64 -#else -pokeLEWord64 = - {-# SCC "pokeLEWord64" #-} - pokeStorable -#endif diff --git a/library/PtrPoker/Poke.hs b/library/PtrPoker/Poke.hs deleted file mode 100644 --- a/library/PtrPoker/Poke.hs +++ /dev/null @@ -1,246 +0,0 @@ -module PtrPoker.Poke where - -import qualified PtrPoker.Compat.ByteString as ByteStringCompat -import qualified PtrPoker.Compat.Text as TextCompat -import qualified PtrPoker.Ffi as Ffi -import qualified PtrPoker.IO.Prim as PrimIO -import PtrPoker.Prelude hiding (concat) - -{-# RULES -"foldMap" forall f foldable. - foldMap f foldable = - Poke $ \p -> foldM (\p (Poke poker) -> poker p) p foldable - #-} - --- | --- Abstraction over an IO action, --- which takes a pointer, populates it and --- produces a pointer right after the populated data. -newtype Poke = Poke {pokePtr :: Ptr Word8 -> IO (Ptr Word8)} - -instance Semigroup Poke where - {-# INLINE [1] (<>) #-} - Poke lIO <> Poke rIO = - Poke (\p -> lIO p >>= rIO) - sconcat = - concat - -instance Monoid Poke where - {-# INLINE [1] mempty #-} - mempty = - Poke return - mconcat = - concat - --- | --- Reuses the IsString instance of 'ByteString'. -instance IsString Poke where - fromString = byteString . fromString - --- | --- Concatenate a foldable of pokes. -{-# INLINE [1] concat #-} -concat :: (Foldable f) => f Poke -> Poke -concat pokers = - Poke (\p -> foldM (\p (Poke io) -> io p) p pokers) - --- | --- Efficiently copy the contents of ByteString using @memcpy@. -{-# INLINE byteString #-} -byteString :: ByteString -> Poke -byteString bs = - Poke $ inline ByteStringCompat.poke bs - --- | --- Encode Word8 as byte, incrementing the pointer by 1. -{-# INLINE [1] word8 #-} -word8 :: Word8 -> Poke -word8 a = - Poke (\p -> PrimIO.pokeWord8 p a $> plusPtr p 1) - --- | --- Encode Word16 in Little-endian. -{-# INLINE [1] lWord16 #-} -lWord16 :: Word16 -> Poke -lWord16 a = - Poke (\p -> PrimIO.pokeLEWord16 p a $> plusPtr p 2) - --- | --- Encode Word16 in Big-endian. -{-# INLINE [1] bWord16 #-} -bWord16 :: Word16 -> Poke -bWord16 a = - Poke (\p -> PrimIO.pokeBEWord16 p a $> plusPtr p 2) - --- | --- Encode Word32 in Little-endian. -{-# INLINE [1] lWord32 #-} -lWord32 :: Word32 -> Poke -lWord32 a = - Poke (\p -> PrimIO.pokeLEWord32 p a $> plusPtr p 4) - --- | --- Encode Word32 in Big-endian. -{-# INLINE [1] bWord32 #-} -bWord32 :: Word32 -> Poke -bWord32 a = - Poke (\p -> PrimIO.pokeBEWord32 p a $> plusPtr p 4) - --- | --- Encode Word64 in Little-endian. -{-# INLINE [1] lWord64 #-} -lWord64 :: Word64 -> Poke -lWord64 a = - Poke (\p -> PrimIO.pokeLEWord64 p a $> plusPtr p 8) - --- | --- Encode Word64 in Big-endian. -{-# INLINE [1] bWord64 #-} -bWord64 :: Word64 -> Poke -bWord64 a = - Poke (\p -> PrimIO.pokeBEWord64 p a $> plusPtr p 8) - --- | --- Encode Int16 in Little-endian. -{-# INLINE lInt16 #-} -lInt16 :: Int16 -> Poke -lInt16 = lWord16 . fromIntegral - --- | --- Encode Int16 in Big-endian. -{-# INLINE bInt16 #-} -bInt16 :: Int16 -> Poke -bInt16 = bWord16 . fromIntegral - --- | --- Encode Int32 in Little-endian. -{-# INLINE lInt32 #-} -lInt32 :: Int32 -> Poke -lInt32 = lWord32 . fromIntegral - --- | --- Encode Int32 in Big-endian. -{-# INLINE bInt32 #-} -bInt32 :: Int32 -> Poke -bInt32 = bWord32 . fromIntegral - --- | --- Encode Int64 in Little-endian. -{-# INLINE lInt64 #-} -lInt64 :: Int64 -> Poke -lInt64 = lWord64 . fromIntegral - --- | --- Encode Int64 in Big-endian. -{-# INLINE bInt64 #-} -bInt64 :: Int64 -> Poke -bInt64 = bWord64 . fromIntegral - --- | --- Encode Text in UTF8. -{-# INLINE textUtf8 #-} -textUtf8 :: Text -> Poke -textUtf8 = Poke . TextCompat.pokeInUtf8 - --- * ASCII integers - -------------------------- - --- | --- Encode Int8 as a signed ASCII decimal. -{-# INLINE [1] int8AsciiDec #-} -int8AsciiDec :: Int8 -> Poke -int8AsciiDec a = - Poke (Ffi.pokeIntInDec (fromIntegral a)) - --- | --- Encode Int16 as a signed ASCII decimal. -{-# INLINE [1] int16AsciiDec #-} -int16AsciiDec :: Int16 -> Poke -int16AsciiDec a = - Poke (Ffi.pokeIntInDec (fromIntegral a)) - --- | --- Encode Int32 as a signed ASCII decimal. -{-# INLINE [1] int32AsciiDec #-} -int32AsciiDec :: Int32 -> Poke -int32AsciiDec a = - Poke (Ffi.pokeIntInDec (fromIntegral a)) - --- | --- Encode Int64 as a signed ASCII decimal. -{-# INLINE [1] int64AsciiDec #-} -int64AsciiDec :: Int64 -> Poke -int64AsciiDec a = - Poke (Ffi.pokeLongLongIntInDec (fromIntegral a)) - --- | --- Encode Int as a signed ASCII decimal. -{-# INLINE [1] intAsciiDec #-} -intAsciiDec :: Int -> Poke -intAsciiDec a = - Poke (Ffi.pokeLongLongIntInDec (fromIntegral a)) - --- | --- Encode Word8 as an unsigned ASCII decimal. -{-# INLINE [1] word8AsciiDec #-} -word8AsciiDec :: Word8 -> Poke -word8AsciiDec a = - Poke (Ffi.pokeUIntInDec (fromIntegral a)) - --- | --- Encode Word16 as an unsigned ASCII decimal. -{-# INLINE [1] word16AsciiDec #-} -word16AsciiDec :: Word16 -> Poke -word16AsciiDec a = - Poke (Ffi.pokeUIntInDec (fromIntegral a)) - --- | --- Encode Word32 as an unsigned ASCII decimal. -{-# INLINE [1] word32AsciiDec #-} -word32AsciiDec :: Word32 -> Poke -word32AsciiDec a = - Poke (Ffi.pokeUIntInDec (fromIntegral a)) - --- | --- Encode Word64 as an unsigned ASCII decimal. -{-# INLINE [1] word64AsciiDec #-} -word64AsciiDec :: Word64 -> Poke -word64AsciiDec a = - Poke (Ffi.pokeLongLongUIntInDec (fromIntegral a)) - --- | --- Encode Word as an unsigned ASCII decimal. -{-# INLINE [1] wordAsciiDec #-} -wordAsciiDec :: Word -> Poke -wordAsciiDec a = - Poke (Ffi.pokeLongLongUIntInDec (fromIntegral a)) - --- | --- Encode Double as a signed ASCII decimal. -{-# INLINE doubleAsciiDec #-} -doubleAsciiDec :: Double -> Poke -doubleAsciiDec a = - Poke $ \ptr -> - Ffi.pokeDouble a ptr - & fmap (plusPtr ptr . fromIntegral) - --- * Low level - -------------------------- - --- | --- Having the amount of bytes to be written precomputed, --- executes an action, --- which fills the pointer going downward, --- starting from the pointer that follows the chunk. --- I.e., you have to decrement the pointer --- before writing the first byte, --- decrement it again before writing the second byte and so on. -{-# INLINE sizedReverse #-} -sizedReverse :: Int -> (Ptr Word8 -> IO a) -> Poke -sizedReverse size action = - Poke $ \ptr -> - let afterPtr = - plusPtr ptr size - in action afterPtr $> afterPtr diff --git a/library/PtrPoker/Prelude.hs b/library/PtrPoker/Prelude.hs deleted file mode 100644 --- a/library/PtrPoker/Prelude.hs +++ /dev/null @@ -1,78 +0,0 @@ -module PtrPoker.Prelude - ( module Exports, - showAsText, - ) -where - -import Control.Applicative as Exports hiding (WrappedArrow (..)) -import Control.Arrow as Exports hiding (first, second) -import Control.Category as Exports -import Control.Concurrent as Exports -import Control.Exception as Exports -import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_) -import Control.Monad.Fail as Exports -import Control.Monad.Fix as Exports hiding (fix) -import Control.Monad.IO.Class as Exports -import Control.Monad.ST as Exports -import Data.Bifunctor as Exports -import Data.Bits as Exports -import Data.Bool as Exports -import Data.ByteString as Exports (ByteString) -import Data.Char as Exports -import Data.Coerce as Exports -import Data.Complex as Exports -import Data.Data as Exports -import Data.Dynamic as Exports -import Data.Either as Exports -import Data.Fixed as Exports -import Data.Foldable as Exports hiding (toList) -import Data.Function as Exports hiding (id, (.)) -import Data.Functor as Exports hiding (unzip) -import Data.Functor.Compose as Exports -import Data.IORef as Exports -import Data.Int as Exports -import Data.Ix as Exports -import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons) -import Data.List.NonEmpty as Exports (NonEmpty (..)) -import Data.Maybe as Exports -import Data.Monoid as Exports hiding (Alt, (<>)) -import Data.Ord as Exports -import Data.Proxy as Exports -import Data.Ratio as Exports -import Data.STRef as Exports -import Data.Scientific as Exports (Scientific) -import Data.Semigroup as Exports hiding (First (..), Last (..)) -import Data.String as Exports -import Data.Text as Exports (Text) -import Data.Traversable as Exports -import Data.Tuple as Exports -import Data.Unique as Exports -import Data.Version as Exports -import Data.Void as Exports -import Data.Word as Exports -import Debug.Trace as Exports -import Foreign.ForeignPtr as Exports -import Foreign.Ptr as Exports -import Foreign.StablePtr as Exports -import Foreign.Storable as Exports -import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar) -import GHC.Exts as Exports (ByteArray#, IsList (..), groupWith, inline, lazy, sortWith) -import GHC.Generics as Exports (Generic) -import GHC.IO.Exception as Exports -import GHC.OverloadedLabels as Exports -import Numeric as Exports -import System.Environment as Exports -import System.Exit as Exports -import System.IO as Exports (Handle, hClose) -import System.IO.Error as Exports -import System.IO.Unsafe as Exports -import System.Mem as Exports -import System.Mem.StableName as Exports -import System.Timeout as Exports -import Text.Printf as Exports (hPrintf, printf) -import Text.Read as Exports (Read (..), readEither, readMaybe) -import Unsafe.Coerce as Exports -import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) - -showAsText :: (Show a) => a -> Text -showAsText = show >>> fromString diff --git a/library/PtrPoker/Size.hs b/library/PtrPoker/Size.hs deleted file mode 100644 --- a/library/PtrPoker/Size.hs +++ /dev/null @@ -1,203 +0,0 @@ --- | --- Functions that compute the required allocation size by value. -module PtrPoker.Size where - -import qualified PtrPoker.Compat.Text as TextCompat -import PtrPoker.Prelude - --- | --- Efficiently count the amount of bytes required to encode Word64 --- as a decimal number in ASCII. --- --- Implemented as a balanced tree of \"ifs\" --- centered around the middle of the range. --- This is much faster than anything based on logarithms. -{-# INLINE word64AsciiDec #-} -word64AsciiDec :: Word64 -> Int -word64AsciiDec x = - if x > 9999999999 - then - if x > 99999999999999 - then - if x > 9999999999999999 - then - if x > 99999999999999999 - then - if x > 999999999999999999 - then - if x > 9999999999999999999 - then 20 - else 19 - else 18 - else 17 - else - if x > 999999999999999 - then 16 - else 15 - else - if x > 999999999999 - then - if x > 9999999999999 - then 14 - else 13 - else - if x > 99999999999 - then 12 - else 11 - else - if x > 99999 - then - if x > 9999999 - then - if x > 99999999 - then - if x > 999999999 - then 10 - else 9 - else 8 - else - if x > 999999 - then 7 - else 6 - else - if x > 99 - then - if x > 999 - then - if x > 9999 - then 5 - else 4 - else 3 - else - if x > 9 - then 2 - else 1 - --- | --- Efficiently count the amount of bytes required to encode Int64 --- as a signed decimal number in ASCII. --- --- Implemented as a balanced tree of \"ifs\" --- centered around the middle of the range. --- This is much faster than anything based on logarithms. -{-# INLINE int64AsciiDec #-} -int64AsciiDec :: Int64 -> Int -int64AsciiDec x = - if x < 0 - then - if x < -9999999999 - then - if x < -99999999999999 - then - if x < -9999999999999999 - then - if x < -99999999999999999 - then - if x < -999999999999999999 - then 20 - else 19 - else 18 - else - if x < -999999999999999 - then 17 - else 16 - else - if x < -999999999999 - then - if x < -9999999999999 - then 15 - else 14 - else - if x < -99999999999 - then 13 - else 12 - else - if x < -99999 - then - if x < -9999999 - then - if x < -99999999 - then - if x < -999999999 - then 11 - else 10 - else 9 - else - if x < -999999 - then 8 - else 7 - else - if x < -99 - then - if x < -999 - then - if x < -9999 - then 6 - else 5 - else 4 - else - if x < -9 - then 3 - else 2 - else - if x > 9999999999 - then - if x > 99999999999999 - then - if x > 9999999999999999 - then - if x > 99999999999999999 - then - if x > 999999999999999999 - then 19 - else 18 - else 17 - else - if x > 999999999999999 - then 16 - else 15 - else - if x > 999999999999 - then - if x > 9999999999999 - then 14 - else 13 - else - if x > 99999999999 - then 12 - else 11 - else - if x > 99999 - then - if x > 9999999 - then - if x > 99999999 - then - if x > 999999999 - then 10 - else 9 - else 8 - else - if x > 999999 - then 7 - else 6 - else - if x > 99 - then - if x > 999 - then - if x > 9999 - then 5 - else 4 - else 3 - else - if x > 9 - then 2 - else 1 - --- | --- Efficiently count the amount of bytes required to encode Text --- in UTF8. -{-# INLINE textUtf8 #-} -textUtf8 :: Text -> Int -textUtf8 = TextCompat.utf8EncodingSize diff --git a/library/PtrPoker/Write.hs b/library/PtrPoker/Write.hs deleted file mode 100644 --- a/library/PtrPoker/Write.hs +++ /dev/null @@ -1,270 +0,0 @@ -module PtrPoker.Write where - -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Internal as ByteString -import qualified PtrPoker.ByteString as ByteString -import qualified PtrPoker.Ffi as Ffi -import qualified PtrPoker.Poke as Poke -import PtrPoker.Prelude hiding (concat) -import qualified PtrPoker.Size as Size - --- | --- Execute Write, producing strict ByteString. -{-# INLINEABLE writeToByteString #-} -writeToByteString :: Write -> ByteString -writeToByteString Write {..} = - ByteString.unsafeCreate writeSize (void . Poke.pokePtr writePoke) - --- | --- Specification of how many bytes to allocate and how to populate them. --- --- Useful for creating strict bytestrings and tasks like that. -data Write = Write - { writeSize :: Int, - writePoke :: Poke.Poke - } - -instance Semigroup Write where - {-# INLINE (<>) #-} - Write lSize lPoke <> Write rSize rPoke = - Write (lSize + rSize) (lPoke <> rPoke) - {-# INLINE sconcat #-} - sconcat = - concat - -instance Monoid Write where - {-# INLINE mempty #-} - mempty = - Write 0 mempty - {-# INLINE mconcat #-} - mconcat = - concat - --- | --- Reuses the IsString instance of 'ByteString'. -instance IsString Write where - {-# INLINE fromString #-} - fromString = - byteString . fromString - --- | --- Concatenate a foldable of writes. -{-# INLINE concat #-} -concat :: (Foldable f) => f Write -> Write -concat f = - Write - (foldl' (\a b -> a + writeSize b) 0 f) - (Poke.Poke (\p -> foldM (\p write -> Poke.pokePtr (writePoke write) p) p f)) - --- | --- Render Word8 as byte. -{-# INLINE word8 #-} -word8 :: Word8 -> Write -word8 a = - Write 1 (Poke.word8 a) - --- | --- Render Word16 in Little-endian. -{-# INLINE lWord16 #-} -lWord16 :: Word16 -> Write -lWord16 a = - Write 2 (Poke.lWord16 a) - --- | --- Render Word16 in Big-endian. -{-# INLINE bWord16 #-} -bWord16 :: Word16 -> Write -bWord16 a = - Write 2 (Poke.bWord16 a) - --- | --- Render Word32 in Little-endian. -{-# INLINE lWord32 #-} -lWord32 :: Word32 -> Write -lWord32 a = - Write 4 (Poke.lWord32 a) - --- | --- Render Word32 in Big-endian. -{-# INLINE bWord32 #-} -bWord32 :: Word32 -> Write -bWord32 a = - Write 4 (Poke.bWord32 a) - --- | --- Render Word64 in Little-endian. -{-# INLINE lWord64 #-} -lWord64 :: Word64 -> Write -lWord64 a = - Write 8 (Poke.lWord64 a) - --- | --- Render Word64 in Big-endian. -{-# INLINE bWord64 #-} -bWord64 :: Word64 -> Write -bWord64 a = - Write 8 (Poke.bWord64 a) - --- | --- Render Int16 in Little-endian. -{-# INLINE lInt16 #-} -lInt16 :: Int16 -> Write -lInt16 a = - Write 2 (Poke.lInt16 a) - --- | --- Render Int16 in Big-endian. -{-# INLINE bInt16 #-} -bInt16 :: Int16 -> Write -bInt16 a = - Write 2 (Poke.bInt16 a) - --- | --- Render Int32 in Little-endian. -{-# INLINE lInt32 #-} -lInt32 :: Int32 -> Write -lInt32 a = - Write 4 (Poke.lInt32 a) - --- | --- Render Int32 in Big-endian. -{-# INLINE bInt32 #-} -bInt32 :: Int32 -> Write -bInt32 a = - Write 4 (Poke.bInt32 a) - --- | --- Render Int64 in Little-endian. -{-# INLINE lInt64 #-} -lInt64 :: Int64 -> Write -lInt64 a = - Write 8 (Poke.lInt64 a) - --- | --- Render Int64 in Big-endian. -{-# INLINE bInt64 #-} -bInt64 :: Int64 -> Write -bInt64 a = - Write 8 (Poke.bInt64 a) - --- | --- Render Word64 in ASCII decimal. -{-# INLINE word64AsciiDec #-} -word64AsciiDec :: Word64 -> Write -word64AsciiDec a = - Write size poke - where - size = - Size.word64AsciiDec a - poke = - Poke.sizedReverse size (Ffi.revPokeUInt64 (fromIntegral a)) - --- | --- Render Word in ASCII decimal. -{-# INLINE wordAsciiDec #-} -wordAsciiDec :: Word -> Write -wordAsciiDec = - word64AsciiDec . fromIntegral - --- | --- Render Int64 in ASCII decimal. -{-# INLINE int64AsciiDec #-} -int64AsciiDec :: Int64 -> Write -int64AsciiDec a = - Write size poke - where - size = - Size.int64AsciiDec a - poke = - Poke.sizedReverse size (Ffi.revPokeInt64 (fromIntegral a)) - --- | --- Render Int in ASCII decimal. -{-# INLINE intAsciiDec #-} -intAsciiDec :: Int -> Write -intAsciiDec = - int64AsciiDec . fromIntegral - --- | --- Render double interpreting non-real values, --- such as @NaN@, @Infinity@, @-Infinity@, --- as is. -{-# INLINE doubleAsciiDec #-} -doubleAsciiDec :: Double -> Write -doubleAsciiDec a = - if a == 0 - then word8 48 - else - if isNaN a - then "NaN" - else - if isInfinite a - then - if a < 0 - then "-Infinity" - else "Infinity" - else - if a < 0 - then word8 45 <> byteString (ByteString.double (negate a)) - else byteString (ByteString.double a) - --- | --- Render double interpreting non real values, --- such as @NaN@, @Infinity@, @-Infinity@, --- as zero. -{-# INLINE zeroNonRealDoubleAsciiDec #-} -zeroNonRealDoubleAsciiDec :: Double -> Write -zeroNonRealDoubleAsciiDec a = - if a == 0 || isNaN a || isInfinite a - then word8 48 - else - if a < 0 - then word8 45 <> byteString (ByteString.double (negate a)) - else byteString (ByteString.double a) - --- | --- Render Scientific in ASCII decimal. -{-# INLINE scientificAsciiDec #-} -scientificAsciiDec :: Scientific -> Write -scientificAsciiDec = - byteString . ByteString.scientific - --- | --- Efficiently copy the contents of ByteString using @memcpy@. -{-# INLINE byteString #-} -byteString :: ByteString -> Write -byteString a = - Write (ByteString.length a) (inline Poke.byteString a) - --- | --- Render Text in UTF8. --- --- Does pretty much the same as 'Data.Text.Encoding.encodeUtf8', --- both implementation and performance-wise, --- while allowing you to avoid redundant @memcpy@ --- compared to @('byteString' . 'Data.Text.Encoding.encodeUtf8')@. --- --- Following are the benchmark results comparing the performance of --- @('writeToByteString' . 'textUtf8')@ with --- @Data.Text.Encoding.'Data.Text.Encoding.encodeUtf8'@ --- on inputs in Latin and Greek (requiring different number of surrogate bytes). --- The results show that they are quite similar. --- --- === __Benchmark results__ --- --- > textUtf8/ptr-poker/latin/1 25.61 ns --- > textUtf8/ptr-poker/latin/10 31.59 ns --- > textUtf8/ptr-poker/latin/100 121.5 ns --- > textUtf8/ptr-poker/greek/1 28.54 ns --- > textUtf8/ptr-poker/greek/10 41.97 ns --- > textUtf8/ptr-poker/greek/100 250.3 ns --- > textUtf8/text/latin/1 22.84 ns --- > textUtf8/text/latin/10 31.10 ns --- > textUtf8/text/latin/100 118.2 ns --- > textUtf8/text/greek/1 25.80 ns --- > textUtf8/text/greek/10 40.80 ns --- > textUtf8/text/greek/100 293.1 ns -{-# INLINEABLE textUtf8 #-} -textUtf8 :: Text -> Write -textUtf8 a = - Write (Size.textUtf8 a) (Poke.textUtf8 a) diff --git a/ptr-poker.cabal b/ptr-poker.cabal --- a/ptr-poker.cabal +++ b/ptr-poker.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ptr-poker -version: 0.1.2.16 +version: 0.1.3 synopsis: Pointer poking action construction and composition toolkit description: Abstraction over memory writes. Efficiently building strict bytestrings is one usecase for it. @@ -16,7 +16,7 @@ source-repository head type: git - location: git://github.com/nikita-volkov/ptr-poker.git + location: https://github.com/nikita-volkov/ptr-poker common base-settings default-language: Haskell2010 @@ -63,7 +63,7 @@ library import: base-settings - hs-source-dirs: library + hs-source-dirs: src/library exposed-modules: PtrPoker.Poke PtrPoker.Size @@ -79,10 +79,10 @@ PtrPoker.Prelude c-sources: - cbits/dtoa.c - cbits/int_encoding.c - cbits/itoa.c - cbits/text.c + src/cbits/dtoa.c + src/cbits/int_encoding.c + src/cbits/itoa.c + src/cbits/text.c build-depends: base >=4.11 && <5, @@ -93,10 +93,18 @@ test-suite test import: base-settings type: exitcode-stdio-1.0 - hs-source-dirs: test + hs-source-dirs: src/test main-is: Main.hs + other-modules: + SizeSpec + WriteSpec + + build-tool-depends: + hspec-discover:hspec-discover >=2.7 && <3 + build-depends: - hedgehog >=1.2 && <2, + QuickCheck >=2.14 && <3, + hspec >=2.7 && <3, isomorphism-class >=0.1 && <0.4, numeric-limits >=0.1 && <0.2, ptr-poker, @@ -105,7 +113,7 @@ benchmark bench import: base-settings type: exitcode-stdio-1.0 - hs-source-dirs: bench + hs-source-dirs: src/bench main-is: Main.hs ghc-options: -O2 diff --git a/src/bench/Main.hs b/src/bench/Main.hs new file mode 100644 --- /dev/null +++ b/src/bench/Main.hs @@ -0,0 +1,72 @@ +module Main where + +import Criterion.Main +import qualified Data.Text.Encoding as Text +import qualified PtrPoker.Write as Write +import Prelude + +main :: IO () +main = + defaultMain + [ bgroup + "bWord32" + [ bench "4" + $ nf + ( \(a, b, c, d) -> + Write.toByteString + $ Write.bWord32 a + <> Write.bWord32 b + <> Write.bWord32 c + <> Write.bWord32 d + ) + (1, 2, 3, 4) + ], + bgroup "textUtf8" + $ let latinSampleBySize size = + enumFromTo 'a' 'z' + & replicate size + & concat + & fromString + greekSampleBySize size = + enumFromTo 'Α' 'Ω' + & replicate size + & concat + & fromString + !latinSample1 = latinSampleBySize 1 + !latinSample10 = latinSampleBySize 10 + !latinSample100 = latinSampleBySize 100 + !greekSample1 = greekSampleBySize 1 + !greekSample10 = greekSampleBySize 10 + !greekSample100 = greekSampleBySize 100 + in [ bgroup + "ptr-poker" + [ bgroup + "latin" + [ bench "1" (nf (Write.toByteString . Write.textUtf8) latinSample1), + bench "10" (nf (Write.toByteString . Write.textUtf8) latinSample10), + bench "100" (nf (Write.toByteString . Write.textUtf8) latinSample100) + ], + bgroup + "greek" + [ bench "1" (nf (Write.toByteString . Write.textUtf8) greekSample1), + bench "10" (nf (Write.toByteString . Write.textUtf8) greekSample10), + bench "100" (nf (Write.toByteString . Write.textUtf8) greekSample100) + ] + ], + bgroup + "text" + [ bgroup + "latin" + [ bench "1" (nf Text.encodeUtf8 latinSample1), + bench "10" (nf Text.encodeUtf8 latinSample10), + bench "100" (nf Text.encodeUtf8 latinSample100) + ], + bgroup + "greek" + [ bench "1" (nf Text.encodeUtf8 greekSample1), + bench "10" (nf Text.encodeUtf8 greekSample10), + bench "100" (nf Text.encodeUtf8 greekSample100) + ] + ] + ] + ] diff --git a/src/cbits/dtoa.c b/src/cbits/dtoa.c new file mode 100644 --- /dev/null +++ b/src/cbits/dtoa.c @@ -0,0 +1,383 @@ +/* +Copyright https://github.com/juj + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*/ +// modified version of https://github.com/juj/MathGeoLib/blob/master/src/Math/grisu3.c +/* This file is part of an implementation of the "grisu3" double to string + conversion algorithm described in the research paper + "Printing Floating-Point Numbers Quickly And Accurately with Integers" + by Florian Loitsch, available at + http://www.cs.tufts.edu/~nr/cs257/archive/florian-loitsch/printf.pdf */ + +#include // uint64_t etc. +#include // assert +#include // ceil +#include // sprintf + +#ifdef _MSC_VER +#pragma warning(disable : 4204) // nonstandard extension used : non-constant aggregate initializer +#endif + +#define D64_SIGN 0x8000000000000000ULL +#define D64_EXP_MASK 0x7FF0000000000000ULL +#define D64_FRACT_MASK 0x000FFFFFFFFFFFFFULL +#define D64_IMPLICIT_ONE 0x0010000000000000ULL +#define D64_EXP_POS 52 +#define D64_EXP_BIAS 1075 +#define DIYFP_FRACT_SIZE 64 +#define D_1_LOG2_10 0.30102999566398114 // 1 / lg(10) +#define MIN_TARGET_EXP -60 +#define MASK32 0xFFFFFFFFULL + +#define CAST_U64(d) (*(uint64_t*)&d) +#define MIN(x,y) ((x) <= (y) ? (x) : (y)) +#define MAX(x,y) ((x) >= (y) ? (x) : (y)) + +#define MIN_CACHED_EXP -348 +#define CACHED_EXP_STEP 8 + +typedef struct diy_fp +{ + uint64_t f; + int e; +} diy_fp; + +typedef struct power +{ + uint64_t fract; + int16_t b_exp, d_exp; +} power; + +static const power pow_cache[] = +{ + { 0xfa8fd5a0081c0288ULL, -1220, -348 }, + { 0xbaaee17fa23ebf76ULL, -1193, -340 }, + { 0x8b16fb203055ac76ULL, -1166, -332 }, + { 0xcf42894a5dce35eaULL, -1140, -324 }, + { 0x9a6bb0aa55653b2dULL, -1113, -316 }, + { 0xe61acf033d1a45dfULL, -1087, -308 }, + { 0xab70fe17c79ac6caULL, -1060, -300 }, + { 0xff77b1fcbebcdc4fULL, -1034, -292 }, + { 0xbe5691ef416bd60cULL, -1007, -284 }, + { 0x8dd01fad907ffc3cULL, -980, -276 }, + { 0xd3515c2831559a83ULL, -954, -268 }, + { 0x9d71ac8fada6c9b5ULL, -927, -260 }, + { 0xea9c227723ee8bcbULL, -901, -252 }, + { 0xaecc49914078536dULL, -874, -244 }, + { 0x823c12795db6ce57ULL, -847, -236 }, + { 0xc21094364dfb5637ULL, -821, -228 }, + { 0x9096ea6f3848984fULL, -794, -220 }, + { 0xd77485cb25823ac7ULL, -768, -212 }, + { 0xa086cfcd97bf97f4ULL, -741, -204 }, + { 0xef340a98172aace5ULL, -715, -196 }, + { 0xb23867fb2a35b28eULL, -688, -188 }, + { 0x84c8d4dfd2c63f3bULL, -661, -180 }, + { 0xc5dd44271ad3cdbaULL, -635, -172 }, + { 0x936b9fcebb25c996ULL, -608, -164 }, + { 0xdbac6c247d62a584ULL, -582, -156 }, + { 0xa3ab66580d5fdaf6ULL, -555, -148 }, + { 0xf3e2f893dec3f126ULL, -529, -140 }, + { 0xb5b5ada8aaff80b8ULL, -502, -132 }, + { 0x87625f056c7c4a8bULL, -475, -124 }, + { 0xc9bcff6034c13053ULL, -449, -116 }, + { 0x964e858c91ba2655ULL, -422, -108 }, + { 0xdff9772470297ebdULL, -396, -100 }, + { 0xa6dfbd9fb8e5b88fULL, -369, -92 }, + { 0xf8a95fcf88747d94ULL, -343, -84 }, + { 0xb94470938fa89bcfULL, -316, -76 }, + { 0x8a08f0f8bf0f156bULL, -289, -68 }, + { 0xcdb02555653131b6ULL, -263, -60 }, + { 0x993fe2c6d07b7facULL, -236, -52 }, + { 0xe45c10c42a2b3b06ULL, -210, -44 }, + { 0xaa242499697392d3ULL, -183, -36 }, + { 0xfd87b5f28300ca0eULL, -157, -28 }, + { 0xbce5086492111aebULL, -130, -20 }, + { 0x8cbccc096f5088ccULL, -103, -12 }, + { 0xd1b71758e219652cULL, -77, -4 }, + { 0x9c40000000000000ULL, -50, 4 }, + { 0xe8d4a51000000000ULL, -24, 12 }, + { 0xad78ebc5ac620000ULL, 3, 20 }, + { 0x813f3978f8940984ULL, 30, 28 }, + { 0xc097ce7bc90715b3ULL, 56, 36 }, + { 0x8f7e32ce7bea5c70ULL, 83, 44 }, + { 0xd5d238a4abe98068ULL, 109, 52 }, + { 0x9f4f2726179a2245ULL, 136, 60 }, + { 0xed63a231d4c4fb27ULL, 162, 68 }, + { 0xb0de65388cc8ada8ULL, 189, 76 }, + { 0x83c7088e1aab65dbULL, 216, 84 }, + { 0xc45d1df942711d9aULL, 242, 92 }, + { 0x924d692ca61be758ULL, 269, 100 }, + { 0xda01ee641a708deaULL, 295, 108 }, + { 0xa26da3999aef774aULL, 322, 116 }, + { 0xf209787bb47d6b85ULL, 348, 124 }, + { 0xb454e4a179dd1877ULL, 375, 132 }, + { 0x865b86925b9bc5c2ULL, 402, 140 }, + { 0xc83553c5c8965d3dULL, 428, 148 }, + { 0x952ab45cfa97a0b3ULL, 455, 156 }, + { 0xde469fbd99a05fe3ULL, 481, 164 }, + { 0xa59bc234db398c25ULL, 508, 172 }, + { 0xf6c69a72a3989f5cULL, 534, 180 }, + { 0xb7dcbf5354e9beceULL, 561, 188 }, + { 0x88fcf317f22241e2ULL, 588, 196 }, + { 0xcc20ce9bd35c78a5ULL, 614, 204 }, + { 0x98165af37b2153dfULL, 641, 212 }, + { 0xe2a0b5dc971f303aULL, 667, 220 }, + { 0xa8d9d1535ce3b396ULL, 694, 228 }, + { 0xfb9b7cd9a4a7443cULL, 720, 236 }, + { 0xbb764c4ca7a44410ULL, 747, 244 }, + { 0x8bab8eefb6409c1aULL, 774, 252 }, + { 0xd01fef10a657842cULL, 800, 260 }, + { 0x9b10a4e5e9913129ULL, 827, 268 }, + { 0xe7109bfba19c0c9dULL, 853, 276 }, + { 0xac2820d9623bf429ULL, 880, 284 }, + { 0x80444b5e7aa7cf85ULL, 907, 292 }, + { 0xbf21e44003acdd2dULL, 933, 300 }, + { 0x8e679c2f5e44ff8fULL, 960, 308 }, + { 0xd433179d9c8cb841ULL, 986, 316 }, + { 0x9e19db92b4e31ba9ULL, 1013, 324 }, + { 0xeb96bf6ebadf77d9ULL, 1039, 332 }, + { 0xaf87023b9bf0ee6bULL, 1066, 340 } +}; + +static int cached_pow(int exp, diy_fp *p) +{ + int k = (int)ceil((exp+DIYFP_FRACT_SIZE-1) * D_1_LOG2_10); + int i = (k-MIN_CACHED_EXP-1) / CACHED_EXP_STEP + 1; + p->f = pow_cache[i].fract; + p->e = pow_cache[i].b_exp; + return pow_cache[i].d_exp; +} + +static diy_fp minus(diy_fp x, diy_fp y) +{ + diy_fp d; d.f = x.f - y.f; d.e = x.e; + assert(x.e == y.e && x.f >= y.f); + return d; +} + +static diy_fp multiply(diy_fp x, diy_fp y) +{ + uint64_t a, b, c, d, ac, bc, ad, bd, tmp; + diy_fp r; + a = x.f >> 32; b = x.f & MASK32; + c = y.f >> 32; d = y.f & MASK32; + ac = a*c; bc = b*c; + ad = a*d; bd = b*d; + tmp = (bd >> 32) + (ad & MASK32) + (bc & MASK32); + tmp += 1U << 31; // round + r.f = ac + (ad >> 32) + (bc >> 32) + (tmp >> 32); + r.e = x.e + y.e + 64; + return r; +} + +static diy_fp normalize_diy_fp(diy_fp n) +{ + assert(n.f != 0); + while(!(n.f & 0xFFC0000000000000ULL)) { n.f <<= 10; n.e -= 10; } + while(!(n.f & D64_SIGN)) { n.f <<= 1; --n.e; } + return n; +} + +static diy_fp double2diy_fp(double d) +{ + diy_fp fp; + uint64_t u64 = CAST_U64(d); + if (!(u64 & D64_EXP_MASK)) { fp.f = u64 & D64_FRACT_MASK; fp.e = 1 - D64_EXP_BIAS; } + else { fp.f = (u64 & D64_FRACT_MASK) + D64_IMPLICIT_ONE; fp.e = (int)((u64 & D64_EXP_MASK) >> D64_EXP_POS) - D64_EXP_BIAS; } + return fp; +} + +// pow10_cache[i] = 10^(i-1) +static const unsigned int pow10_cache[] = { 0, 1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000 }; + +static int largest_pow10(uint32_t n, int n_bits, uint32_t *power) +{ + int guess = ((n_bits + 1) * 1233 >> 12) + 1/*skip first entry*/; + if (n < pow10_cache[guess]) --guess; // We don't have any guarantees that 2^n_bits <= n. + *power = pow10_cache[guess]; + return guess; +} + +static int round_weed(char *buffer, int len, uint64_t wp_W, uint64_t delta, uint64_t rest, uint64_t ten_kappa, uint64_t ulp) +{ + uint64_t wp_Wup = wp_W - ulp; + uint64_t wp_Wdown = wp_W + ulp; + while(rest < wp_Wup && delta - rest >= ten_kappa + && (rest + ten_kappa < wp_Wup || wp_Wup - rest >= rest + ten_kappa - wp_Wup)) + { + --buffer[len-1]; + rest += ten_kappa; + } + if (rest < wp_Wdown && delta - rest >= ten_kappa + && (rest + ten_kappa < wp_Wdown || wp_Wdown - rest > rest + ten_kappa - wp_Wdown)) + return 0; + + return 2*ulp <= rest && rest <= delta - 4*ulp; +} + +static int digit_gen(diy_fp low, diy_fp w, diy_fp high, char *buffer, int *length, int *kappa) +{ + uint64_t unit = 1; + diy_fp too_low = { low.f - unit, low.e }; + diy_fp too_high = { high.f + unit, high.e }; + diy_fp unsafe_interval = minus(too_high, too_low); + diy_fp one = { 1ULL << -w.e, w.e }; + uint32_t p1 = (uint32_t)(too_high.f >> -one.e); + uint64_t p2 = too_high.f & (one.f - 1); + uint32_t div; + *kappa = largest_pow10(p1, DIYFP_FRACT_SIZE + one.e, &div); + *length = 0; + + while(*kappa > 0) + { + uint64_t rest; + int digit = p1 / div; + buffer[*length] = (char)('0' + digit); + ++*length; + p1 %= div; + --*kappa; + rest = ((uint64_t)p1 << -one.e) + p2; + if (rest < unsafe_interval.f) return round_weed(buffer, *length, minus(too_high, w).f, unsafe_interval.f, rest, (uint64_t)div << -one.e, unit); + div /= 10; + } + + for(;;) + { + int digit; + p2 *= 10; + unit *= 10; + unsafe_interval.f *= 10; + // Integer division by one. + digit = (int)(p2 >> -one.e); + buffer[*length] = (char)('0' + digit); + ++*length; + p2 &= one.f - 1; // Modulo by one. + --*kappa; + if (p2 < unsafe_interval.f) return round_weed(buffer, *length, minus(too_high, w).f * unit, unsafe_interval.f, p2, one.f, unit); + } +} + +int grisu3(double v, char *buffer, int *length, int *d_exp) +{ + int mk, kappa, success; + diy_fp dfp = double2diy_fp(v); + diy_fp w = normalize_diy_fp(dfp); + + // normalize boundaries + diy_fp t = { (dfp.f << 1) + 1, dfp.e - 1 }; + diy_fp b_plus = normalize_diy_fp(t); + diy_fp b_minus; + diy_fp c_mk; // Cached power of ten: 10^-k + uint64_t u64 = CAST_U64(v); + assert(v > 0 && v <= 1.7976931348623157e308); // Grisu only handles strictly positive finite numbers. + if (!(u64 & D64_FRACT_MASK) && (u64 & D64_EXP_MASK) != 0) { b_minus.f = (dfp.f << 2) - 1; b_minus.e = dfp.e - 2;} // lower boundary is closer? + else { b_minus.f = (dfp.f << 1) - 1; b_minus.e = dfp.e - 1; } + b_minus.f = b_minus.f << (b_minus.e - b_plus.e); + b_minus.e = b_plus.e; + + mk = cached_pow(MIN_TARGET_EXP - DIYFP_FRACT_SIZE - w.e, &c_mk); + + w = multiply(w, c_mk); + b_minus = multiply(b_minus, c_mk); + b_plus = multiply(b_plus, c_mk); + + success = digit_gen(b_minus, w, b_plus, buffer, length, &kappa); + *d_exp = kappa - mk; + return success; +} + +static int i_to_str(int val, char *str) +{ + int len, i; + char *s; + char *begin = str; + if (val < 0) { *str++ = '-'; val = -val; } + s = str; + + for(;;) + { + int ni = val / 10; + int digit = val - ni*10; + *s++ = (char)('0' + digit); + if (ni == 0) + break; + val = ni; + } + *s = '\0'; + len = (int)(s - str); + for(i = 0; i < len/2; ++i) + { + char ch = str[i]; + str[i] = str[len-1-i]; + str[len-1-i] = ch; + } + + return (int)(s - begin); +} + +int dtoa_grisu3(double v, char *dst) +{ + int d_exp, len, decimals, i; + + int success = grisu3(v, dst, &len, &d_exp); + // If grisu3 was not able to convert the number to a string, then use old sprintf (suboptimal). + if (!success) return sprintf(dst, "%.17g", v) + (int)(dst - dst); + + // We now have an integer string of form "151324135" and a base-10 exponent for that number. + // Next, decide the best presentation for that string by whether to use a decimal point, or the scientific exponent notation 'e'. + // We don't pick the absolute shortest representation, but pick a balance between readability and shortness, e.g. + // 1.545056189557677e-308 could be represented in a shorter form + // 1545056189557677e-323 but that would be somewhat unreadable. + decimals = MIN(-d_exp, MAX(1, len-1)); + if (d_exp < 0 && len > 1) // Add decimal point? + { + int dot_pos = len-decimals; + if (dot_pos == 0) { + for(i = 0; i < decimals; ++i) { + dst[len-i+1] = dst[len-i-1]; + } + // put a 0 in front of the decimal point to make it a valid Haskell floating point number. + dst[0] = '0'; + dst[1] = '.'; + len+= 2; + } else { + for(i = 0; i < decimals; ++i) { + dst[len-i] = dst[len-i-1]; + } + dst[dot_pos] = '.'; + len++; + } + + d_exp += decimals; + // Need scientific notation as well? + if (d_exp != 0) { dst[len++] = 'e'; len += i_to_str(d_exp, dst+len); } + } + else if (d_exp < 0 && d_exp >= -3) // Add decimal point for numbers of form 0.000x where it's shorter? + { + // len here is 1! + dst[1-d_exp] = dst[0]; + // put a 0 in front of the decimal point to make it a valid Haskell floating point number. + dst[0] = '0'; + dst[1] = '.'; + for(i = 2; i < (1-d_exp); ++i) dst[i] = '0'; + len += -d_exp+1; + } + // Add scientific notation? + else if (d_exp < 0 || d_exp > 2) { dst[len++] = 'e'; len += i_to_str(d_exp, dst+len); } + // Add zeroes instead of scientific notation? + else if (d_exp > 0) { while(d_exp-- > 0) dst[len++] = '0'; } + // dst[len] = '\0'; // grisu3 doesn't null terminate, so ensure termination. + return (int)(dst+len-dst); +} diff --git a/src/cbits/int_encoding.c b/src/cbits/int_encoding.c new file mode 100644 --- /dev/null +++ b/src/cbits/int_encoding.c @@ -0,0 +1,65 @@ +/* + * Copyright (c) 2020 Nikita Volkov . + */ + +#include +#include +#include +#include +#include + + +void rev_poke_int64 +( + int64_t val, + uint8_t* dst +) +{ + bool negate = false; + + if (val < 0) + { + int64_t b4 = val; + val /= 10; + if (val) + { + *--dst = val * 10 - b4 + 48; + val = -val; + negate = true; + } + else + { + *(dst - 1) = val * 10 - b4 + 48; + *(dst - 2) = '-'; + return; + } + } + + do + { + int64_t b4 = val; + val /= 10; + *--dst = b4 - val * 10 + 48; + } + while (val); + + if (negate) + { + *--dst = '-'; + } +} + +void rev_poke_uint64 +( + uint64_t val, + uint8_t* dst +) +{ + do + { + uint64_t b4 = val; + val /= 10; + *--dst = b4 - val * 10 + 48; + } + while (val); +} diff --git a/src/cbits/itoa.c b/src/cbits/itoa.c new file mode 100644 --- /dev/null +++ b/src/cbits/itoa.c @@ -0,0 +1,216 @@ +/////////////////////////////////////////////////////////////// +// Encoding numbers using ASCII characters // +// // +// inspired by: http://www.jb.man.ac.uk/~slowe/cpp/itoa.html // +// Borrowed from the "bytestring" library // +/////////////////////////////////////////////////////////////// + +#include + +// Decimal Encoding +/////////////////// + +static const char* digits = "0123456789abcdef"; + +// signed integers +char* int_dec (int x, char* buf) +{ + char c, *ptr = buf, *next_free; + int x_tmp; + + // we cannot negate directly as 0 - (minBound :: Int) = minBound + if (x < 0) { + *ptr++ = '-'; + buf++; + x_tmp = x; + x /= 10; + *ptr++ = digits[x * 10 - x_tmp]; + if (x == 0) + return ptr; + else + x = -x; + } + + // encode positive number as little-endian decimal + do { + x_tmp = x; + x /= 10; + *ptr++ = digits[x_tmp - x * 10]; + } while ( x ); + + // reverse written digits + next_free = ptr--; + while (buf < ptr) { + c = *ptr; + *ptr-- = *buf; + *buf++ = c; + } + return next_free; +} + +// signed long long ints (64 bit integers) +char* long_long_int_dec (long long int x, char* buf) +{ + char c, *ptr = buf, *next_free; + long long int x_tmp; + + // we cannot negate directly as 0 - (minBound :: Int) = minBound + if (x < 0) { + *ptr++ = '-'; + buf++; + x_tmp = x; + x /= 10; + *ptr++ = digits[x * 10 - x_tmp]; + if (x == 0) + return ptr; + else + x = -x; + } + + // encode positive number as little-endian decimal + do { + x_tmp = x; + x /= 10; + *ptr++ = digits[x_tmp - x * 10]; + } while ( x ); + + // reverse written digits + next_free = ptr--; + while (buf < ptr) { + c = *ptr; + *ptr-- = *buf; + *buf++ = c; + } + return next_free; +} + +// unsigned integers +char* uint_dec (unsigned int x, char* buf) +{ + char c, *ptr = buf, *next_free; + unsigned int x_tmp; + + // encode positive number as little-endian decimal + do { + x_tmp = x; + x /= 10; + *ptr++ = digits[x_tmp - x * 10]; + } while ( x ); + + // reverse written digits + next_free = ptr--; + while (buf < ptr) { + c = *ptr; + *ptr-- = *buf; + *buf++ = c; + } + return next_free; +} + +// unsigned long ints +char* long_long_uint_dec (long long unsigned int x, char* buf) +{ + char c, *ptr = buf, *next_free; + long long unsigned int x_tmp; + + // encode positive number as little-endian decimal + do { + x_tmp = x; + x /= 10; + *ptr++ = digits[x_tmp - x * 10]; + } while ( x ); + + // reverse written digits + next_free = ptr--; + while (buf < ptr) { + c = *ptr; + *ptr-- = *buf; + *buf++ = c; + } + return next_free; +} + + +// Padded, decimal, positive integers for the decimal output of bignums +/////////////////////////////////////////////////////////////////////// + +// Padded (9 digits), decimal, positive int: +// We will use it with numbers that fit in 31 bits; i.e., numbers smaller than +// 10^9, as "31 * log 2 / log 10 = 9.33" +void int_dec_padded9 (int x, char* buf) +{ + const int max_width_int32_dec = 9; + char* ptr = buf + max_width_int32_dec; + int x_tmp; + + // encode positive number as little-endian decimal + do { + x_tmp = x; + x /= 10; + *(--ptr) = digits[x_tmp - x * 10]; + } while ( x ); + + // pad beginning + while (buf < ptr) { *(--ptr) = '0'; } +} + +// Padded (19 digits), decimal, positive long long int: +// We will use it with numbers that fit in 63 bits; i.e., numbers smaller than +// 10^18, as "63 * log 2 / log 10 = 18.96" +void long_long_int_dec_padded18 (long long int x, char* buf) +{ + const int max_width_int64_dec = 18; + char* ptr = buf + max_width_int64_dec; + long long int x_tmp; + + // encode positive number as little-endian decimal + do { + x_tmp = x; + x /= 10; + *(--ptr) = digits[x_tmp - x * 10]; + } while ( x ); + + // pad beginning + while (buf < ptr) { *(--ptr) = '0'; } +} + + +/////////////////////// +// Hexadecimal encoding +/////////////////////// + +// unsigned ints (32 bit words) +char* uint_hex (unsigned int x, char* buf) { + // write hex representation in reverse order + char c, *ptr = buf, *next_free; + do { + *ptr++ = digits[x & 0xf]; + x >>= 4; + } while ( x ); + // invert written digits + next_free = ptr--; + while(buf < ptr) { + c = *ptr; + *ptr-- = *buf; + *buf++ = c; + } + return next_free; +}; + +// unsigned long ints (64 bit words) +char* long_long_uint_hex (long long unsigned int x, char* buf) { + // write hex representation in reverse order + char c, *ptr = buf, *next_free; + do { + *ptr++ = digits[x & 0xf]; + x >>= 4; + } while ( x ); + // invert written digits + next_free = ptr--; + while(buf < ptr) { + c = *ptr; + *ptr-- = *buf; + *buf++ = c; + } + return next_free; +}; diff --git a/src/cbits/text.c b/src/cbits/text.c new file mode 100644 --- /dev/null +++ b/src/cbits/text.c @@ -0,0 +1,232 @@ +/* + * Copyright (c) 2020 Nikita Volkov . + * + * Portions copyright (c) 2011 Bryan O'Sullivan . + * + * Portions copyright (c) 2008-2010 Björn Höhrmann . + * + * See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details. + */ + +#include +#include +#include +#include + + +uint8_t* encode_text +( + uint8_t *dest, + const uint16_t *src, + size_t src_offset, + size_t src_length +) +#if defined(__x86_64__) +{ + + src += src_offset; + + const uint16_t* src_end = src + src_length; + const uint16_t* full_word_src_end = src_end - 4; + + while (src < src_end) { + uint16_t x = *src++; + + if (x <= 0x7F) { + *dest++ = x; + + while (src < full_word_src_end) { + uint64_t x = *((uint64_t *) src); + + if (x & 0xFF80FF80FF80FF80ULL) { + if (!(x & 0x000000000000FF80ULL)) { + *dest++ = x & 0xFFFF; + src++; + if (!(x & 0x00000000FF800000ULL)) { + *dest++ = (x >> 16) & 0xFFFF; + src++; + if (!(x & 0x0000FF8000000000ULL)) { + *dest++ = (x >> 32) & 0xFFFF; + src++; + } + } + } + break; + } + + *dest++ = x & 0xFFFF; + *dest++ = (x >> 16) & 0xFFFF; + *dest++ = (x >> 32) & 0xFFFF; + *dest++ = x >> 48; + src += 4; + } + } + else if (x <= 0x7FF) { + *dest++ = (x >> 6) | 0xC0; + *dest++ = (x & 0x3f) | 0x80; + } + else if (x < 0xD800 || x > 0xDBFF) { + *dest++ = (x >> 12) | 0xE0; + *dest++ = ((x >> 6) & 0x3F) | 0x80; + *dest++ = (x & 0x3F) | 0x80; + } else { + uint32_t c = + ((((uint32_t) x) - 0xD800) << 10) + + (((uint32_t) *src++) - 0xDC00) + 0x10000; + *dest++ = (c >> 18) | 0xF0; + *dest++ = ((c >> 12) & 0x3F) | 0x80; + *dest++ = ((c >> 6) & 0x3F) | 0x80; + *dest++ = (c & 0x3F) | 0x80; + } + } + + return dest; +} +#else +{ + + src += src_offset; + + const uint16_t* src_end = src + src_length; + const uint16_t* full_word_src_end = src_end - 2; + + while (src < src_end) { + uint16_t x = *src++; + + if (x <= 0x7F) { + *dest++ = x; + + while (src < full_word_src_end) { + uint32_t x = *((uint32_t *) src); + + if (x & 0xFF80FF80) + break; + *dest++ = x & 0xFFFF; + *dest++ = x >> 16; + src += 2; + } + + } + else if (x <= 0x7FF) { + *dest++ = (x >> 6) | 0xC0; + *dest++ = (x & 0x3f) | 0x80; + } + else if (x < 0xD800 || x > 0xDBFF) { + *dest++ = (x >> 12) | 0xE0; + *dest++ = ((x >> 6) & 0x3F) | 0x80; + *dest++ = (x & 0x3F) | 0x80; + } else { + uint32_t c = + ((((uint32_t) x) - 0xD800) << 10) + + (((uint32_t) *src++) - 0xDC00) + 0x10000; + *dest++ = (c >> 18) | 0xF0; + *dest++ = ((c >> 12) & 0x3F) | 0x80; + *dest++ = ((c >> 6) & 0x3F) | 0x80; + *dest++ = (c & 0x3F) | 0x80; + } + } + + return dest; +} +#endif + + +int count_text_allocation_size +( + const uint16_t *src_ptr, + size_t src_off, + size_t src_len +) +#if defined(__x86_64__) +{ + src_ptr += src_off; + + const uint16_t* after_src_ptr = src_ptr + src_len; + const uint16_t* full_word_after_src_ptr = after_src_ptr - 4; + + size_t size = 0; + + while (src_ptr < after_src_ptr) { + uint16_t w = *src_ptr++; + + if (w <= 0x7F) { + size += 1; + + /* Try to go in batches of 4 bytes. */ + while (src_ptr < full_word_after_src_ptr) { + uint64_t x = *((uint64_t*) src_ptr); + + if (x & 0xFF80FF80FF80FF80ULL) { + if (!(x & 0x000000000000FF80ULL)) { + size++; + src_ptr++; + if (!(x & 0x00000000FF800000ULL)) { + size++; + src_ptr++; + if (!(x & 0x0000FF8000000000ULL)) { + size++; + src_ptr++; + } + } + } + break; + } + + size += 4; + src_ptr += 4; + } + + } + else if (w <= 0x7FF) { + size += 2; + } + else if (w < 0xD800 || w > 0xDBFF) { + size += 3; + } else { + src_ptr++; + size += 4; + } + } + + return size; +} +#else +{ + src_ptr += src_off; + + const uint16_t* after_src_ptr = src_ptr + src_len; + const uint16_t* full_word_after_src_ptr = after_src_ptr - 2; + + size_t size = 0; + + while (src_ptr < after_src_ptr) { + uint16_t w = *src_ptr++; + + if (w <= 0x7F) { + size += 1; + + /* Try to go in batches of 2 bytes. */ + while (src_ptr < full_word_after_src_ptr) { + uint32_t x = *((uint32_t *) src_ptr); + + if (x & 0xFF80FF80) break; + + size += 2; + src_ptr += 2; + } + + } + else if (w <= 0x7FF) { + size += 2; + } + else if (w < 0xD800 || w > 0xDBFF) { + size += 3; + } else { + src_ptr++; + size += 4; + } + } + + return size; +} +#endif diff --git a/src/library/PtrPoker/ByteString.hs b/src/library/PtrPoker/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/library/PtrPoker/ByteString.hs @@ -0,0 +1,43 @@ +module PtrPoker.ByteString where + +import Data.ByteString +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Builder.Extra as Builder +import qualified Data.ByteString.Builder.Scientific as ScientificBuilder +import Data.ByteString.Internal +import qualified Data.ByteString.Lazy as Lazy +import qualified PtrPoker.Compat.Text as TextCompat +import qualified PtrPoker.Ffi as Ffi +import PtrPoker.Prelude hiding (empty) + +builderWithStrategy :: Builder.AllocationStrategy -> Builder.Builder -> ByteString +builderWithStrategy strategy builder = + builder + & Builder.toLazyByteStringWith strategy Lazy.empty + & Lazy.toStrict + +scientific :: Scientific -> ByteString +scientific sci = + sci + & ScientificBuilder.scientificBuilder + & builderWithStrategy (Builder.untrimmedStrategy 128 128) + +double :: Double -> ByteString +double dbl = + unsafeCreateUptoN + 25 + ( \ptr -> + Ffi.pokeDouble dbl ptr + & fmap fromIntegral + ) + +unsafeCreateDownToN :: Int -> (Ptr Word8 -> IO Int) -> ByteString +unsafeCreateDownToN allocSize populate = + unsafeDupablePerformIO $ do + fp <- mallocByteString allocSize + actualSize <- withForeignPtr fp (\p -> populate (plusPtr p (pred allocSize))) + return $! PS fp (allocSize - actualSize) actualSize + +{-# INLINE textUtf8 #-} +textUtf8 :: Text -> ByteString +textUtf8 = TextCompat.encodeInUtf8 diff --git a/src/library/PtrPoker/Compat/ByteString.hs b/src/library/PtrPoker/Compat/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/library/PtrPoker/Compat/ByteString.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE CPP #-} + +module PtrPoker.Compat.ByteString (poke) where + +import Data.ByteString.Internal +import Foreign.Marshal.Utils +import qualified PtrPoker.Compat.ForeignPtr as ForeignPtr +import PtrPoker.Prelude hiding (poke) + +{-# INLINE poke #-} +poke :: ByteString -> Ptr Word8 -> IO (Ptr Word8) + +#if MIN_VERSION_bytestring(0,11,0) + +poke (BS fptr length) ptr = + {-# SCC "poke" #-} + ForeignPtr.unsafeWithForeignPtr fptr $ \ bytesPtr -> + copyBytes ptr bytesPtr length $> + plusPtr ptr length + +#else + +poke (PS fptr offset length) ptr = + {-# SCC "poke" #-} + ForeignPtr.unsafeWithForeignPtr fptr $ \ bytesPtr -> + copyBytes ptr (plusPtr bytesPtr offset) length $> + plusPtr ptr length + +#endif diff --git a/src/library/PtrPoker/Compat/ForeignPtr.hs b/src/library/PtrPoker/Compat/ForeignPtr.hs new file mode 100644 --- /dev/null +++ b/src/library/PtrPoker/Compat/ForeignPtr.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} + +module PtrPoker.Compat.ForeignPtr where + +import PtrPoker.Prelude + +#if MIN_VERSION_base(4,15,0) +import qualified GHC.ForeignPtr +#else +import qualified Foreign.ForeignPtr +#endif + +-- | 'unsafeWithForeignPtr' compatibility wrapper. +-- +-- GHC 9.0 made 'withForeignPtr' sound at the cost of performance. If you want to +-- use the faster unsafe implementation, it's now at 'unsafeWithForeignPtr', and +-- GHC asks you to promise that your continuation does not diverge. All we do here +-- is @memcpy@ bytestrings, so we gladly pinky swear. For more detail, see Ben +-- Gamari's post: +-- +-- +-- Note that fumieval's mason uses 'unsafeWithForeignPtr' in the same way also to +-- copy bytestrings. +{-# INLINE unsafeWithForeignPtr #-} +unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b +#if MIN_VERSION_base(4,15,0) +unsafeWithForeignPtr = + GHC.ForeignPtr.unsafeWithForeignPtr +#else +unsafeWithForeignPtr = + -- same implementation as new @unsafeWithForeignPtr@ (it was always unsafe) + Foreign.ForeignPtr.withForeignPtr +#endif diff --git a/src/library/PtrPoker/Compat/Text.hs b/src/library/PtrPoker/Compat/Text.hs new file mode 100644 --- /dev/null +++ b/src/library/PtrPoker/Compat/Text.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE CPP #-} + +module PtrPoker.Compat.Text where + +#if MIN_VERSION_text(2,0,0) +import qualified Data.Text.Array as TextArray +import qualified Data.Text.Encoding as TextEncoding +import qualified Data.Text.Internal as TextInternal +import PtrPoker.Prelude + +{-# INLINE destruct #-} +destruct :: (ByteArray# -> Int -> Int -> x) -> Text -> x +destruct k (TextInternal.Text (TextArray.ByteArray arr) off len) = k arr off len + +{-# INLINE utf8EncodingSize #-} +utf8EncodingSize :: Text -> Int +utf8EncodingSize = destruct $ \_arr _off len -> len + +{-# INLINEABLE encodeInUtf8 #-} +encodeInUtf8 :: Text -> ByteString +encodeInUtf8 t = TextEncoding.encodeUtf8 t + +{-# INLINE pokeInUtf8 #-} +pokeInUtf8 :: Text -> Ptr Word8 -> IO (Ptr Word8) +pokeInUtf8 (TextInternal.Text arr off len) p = + stToIO (TextArray.copyToPointer arr off p len) $> plusPtr p len +#else +import qualified Data.ByteString.Internal as ByteStringInternal +import qualified Data.Text.Array as TextArray +import qualified Data.Text.Internal as TextInternal +import qualified PtrPoker.Ffi as Ffi +import PtrPoker.Prelude + +{-# INLINE destruct #-} +destruct :: (ByteArray# -> Int -> Int -> x) -> Text -> x +destruct k (TextInternal.Text (TextArray.Array arr) off len) = + k arr off len + +{-# INLINEABLE utf8EncodingSize #-} +utf8EncodingSize :: Text -> Int +utf8EncodingSize (TextInternal.Text (TextArray.Array arr) off len) = + Ffi.countTextAllocationSize + arr + (fromIntegral off) + (fromIntegral len) + & unsafeDupablePerformIO + & fromIntegral + +{-# INLINEABLE encodeInUtf8 #-} +encodeInUtf8 :: Text -> ByteString +encodeInUtf8 (TextInternal.Text (TextArray.Array arr) off len) = + if len == 0 + then mempty + else ByteStringInternal.unsafeCreateUptoN (len * 3) $ \ptr -> do + postPtr <- inline Ffi.encodeText ptr arr (fromIntegral off) (fromIntegral len) + return (minusPtr postPtr ptr) + +{-# INLINE pokeInUtf8 #-} +pokeInUtf8 :: Text -> Ptr Word8 -> IO (Ptr Word8) +pokeInUtf8 (TextInternal.Text (TextArray.Array arr) off len) p = + Ffi.encodeText p arr (fromIntegral off) (fromIntegral len) +#endif diff --git a/src/library/PtrPoker/Ffi.hs b/src/library/PtrPoker/Ffi.hs new file mode 100644 --- /dev/null +++ b/src/library/PtrPoker/Ffi.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE UnliftedFFITypes #-} + +module PtrPoker.Ffi where + +import Foreign.C +import PtrPoker.Prelude + +foreign import ccall unsafe "static int_dec" + pokeIntInDec :: CInt -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static long_long_int_dec" + pokeLongLongIntInDec :: CLLong -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static uint_dec" + pokeUIntInDec :: CUInt -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static long_long_uint_dec" + pokeLongLongUIntInDec :: CULLong -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static uint_hex" + pokeUIntInHex :: CUInt -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static long_long_uint_hex" + pokeLongLongUIntInHex :: CULLong -> Ptr Word8 -> IO (Ptr Word8) + +foreign import ccall unsafe "static rev_poke_int64" + revPokeInt64 :: CLLong -> Ptr Word8 -> IO () + +foreign import ccall unsafe "static rev_poke_uint64" + revPokeUInt64 :: CULLong -> Ptr Word8 -> IO () + +foreign import ccall unsafe "static dtoa_grisu3" + pokeDouble :: Double -> Ptr Word8 -> IO CInt + +foreign import ccall unsafe "static count_text_allocation_size" + countTextAllocationSize :: ByteArray# -> CSize -> CSize -> IO CInt + +foreign import ccall unsafe "static encode_text" + encodeText :: Ptr Word8 -> ByteArray# -> CSize -> CSize -> IO (Ptr Word8) diff --git a/src/library/PtrPoker/IO/Prim.hs b/src/library/PtrPoker/IO/Prim.hs new file mode 100644 --- /dev/null +++ b/src/library/PtrPoker/IO/Prim.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE CPP #-} + +module PtrPoker.IO.Prim where + +import PtrPoker.Prelude + +{-# INLINE pokeStorable #-} +pokeStorable :: (Storable a) => Ptr Word8 -> a -> IO () +pokeStorable ptr value = + {-# SCC "pokeStorable" #-} + poke (castPtr ptr) value + +{-# INLINE pokeWord8 #-} +pokeWord8 :: Ptr Word8 -> Word8 -> IO () +pokeWord8 ptr value = + {-# SCC "pokeWord8" #-} + poke ptr value + +{-# INLINE pokeWord8Off #-} +pokeWord8Off :: Ptr Word8 -> Int -> Word8 -> IO () +pokeWord8Off ptr off value = + {-# SCC "pokeWord8Off" #-} + pokeByteOff ptr off value + +{-# INLINE pokeBEWord16 #-} +pokeBEWord16 :: Ptr Word8 -> Word16 -> IO () +#ifdef WORDS_BIGENDIAN +pokeBEWord16 = + {-# SCC "pokeBEWord16" #-} + pokeStorable +#else +pokeBEWord16 ptr = + {-# SCC "pokeBEWord16" #-} + pokeStorable ptr . byteSwap16 +#endif + +{-# INLINE pokeBEWord32 #-} +pokeBEWord32 :: Ptr Word8 -> Word32 -> IO () +#ifdef WORDS_BIGENDIAN +pokeBEWord32 = + {-# SCC "pokeBEWord32" #-} + pokeStorable +#else +pokeBEWord32 ptr = + {-# SCC "pokeBEWord32" #-} + pokeStorable ptr . byteSwap32 +#endif + +{-# INLINE pokeBEWord64 #-} +pokeBEWord64 :: Ptr Word8 -> Word64 -> IO () +#ifdef WORDS_BIGENDIAN +pokeBEWord64 = + {-# SCC "pokeBEWord64" #-} + pokeStorable +#else +pokeBEWord64 ptr = + {-# SCC "pokeBEWord64" #-} + pokeStorable ptr . byteSwap64 +#endif + +{-# INLINE pokeLEWord16 #-} +pokeLEWord16 :: Ptr Word8 -> Word16 -> IO () +#ifdef WORDS_BIGENDIAN +pokeLEWord16 ptr = + {-# SCC "pokeLEWord16" #-} + pokeStorable ptr . byteSwap16 +#else +pokeLEWord16 = + {-# SCC "pokeLEWord16" #-} + pokeStorable +#endif + +{-# INLINE pokeLEWord32 #-} +pokeLEWord32 :: Ptr Word8 -> Word32 -> IO () +#ifdef WORDS_BIGENDIAN +pokeLEWord32 ptr = + {-# SCC "pokeLEWord32" #-} + pokeStorable ptr . byteSwap32 +#else +pokeLEWord32 = + {-# SCC "pokeLEWord32" #-} + pokeStorable +#endif + +{-# INLINE pokeLEWord64 #-} +pokeLEWord64 :: Ptr Word8 -> Word64 -> IO () +#ifdef WORDS_BIGENDIAN +pokeLEWord64 ptr = + {-# SCC "pokeLEWord64" #-} + pokeStorable ptr . byteSwap64 +#else +pokeLEWord64 = + {-# SCC "pokeLEWord64" #-} + pokeStorable +#endif diff --git a/src/library/PtrPoker/Poke.hs b/src/library/PtrPoker/Poke.hs new file mode 100644 --- /dev/null +++ b/src/library/PtrPoker/Poke.hs @@ -0,0 +1,246 @@ +module PtrPoker.Poke where + +import qualified PtrPoker.Compat.ByteString as ByteStringCompat +import qualified PtrPoker.Compat.Text as TextCompat +import qualified PtrPoker.Ffi as Ffi +import qualified PtrPoker.IO.Prim as PrimIO +import PtrPoker.Prelude hiding (concat) + +{-# RULES +"foldMap" forall f foldable. + foldMap f foldable = + Poke $ \p -> foldM (\p (Poke poker) -> poker p) p foldable + #-} + +-- | +-- Abstraction over an IO action, +-- which takes a pointer, populates it and +-- produces a pointer right after the populated data. +newtype Poke = Poke {pokePtr :: Ptr Word8 -> IO (Ptr Word8)} + +instance Semigroup Poke where + {-# INLINE [1] (<>) #-} + Poke lIO <> Poke rIO = + Poke (\p -> lIO p >>= rIO) + sconcat = + concat + +instance Monoid Poke where + {-# INLINE [1] mempty #-} + mempty = + Poke return + mconcat = + concat + +-- | +-- Reuses the IsString instance of 'ByteString'. +instance IsString Poke where + fromString = byteString . fromString + +-- | +-- Concatenate a foldable of pokes. +{-# INLINE [1] concat #-} +concat :: (Foldable f) => f Poke -> Poke +concat pokers = + Poke (\p -> foldM (\p (Poke io) -> io p) p pokers) + +-- | +-- Efficiently copy the contents of ByteString using @memcpy@. +{-# INLINE byteString #-} +byteString :: ByteString -> Poke +byteString bs = + Poke $ inline ByteStringCompat.poke bs + +-- | +-- Encode Word8 as byte, incrementing the pointer by 1. +{-# INLINE [1] word8 #-} +word8 :: Word8 -> Poke +word8 a = + Poke (\p -> PrimIO.pokeWord8 p a $> plusPtr p 1) + +-- | +-- Encode Word16 in Little-endian. +{-# INLINE [1] lWord16 #-} +lWord16 :: Word16 -> Poke +lWord16 a = + Poke (\p -> PrimIO.pokeLEWord16 p a $> plusPtr p 2) + +-- | +-- Encode Word16 in Big-endian. +{-# INLINE [1] bWord16 #-} +bWord16 :: Word16 -> Poke +bWord16 a = + Poke (\p -> PrimIO.pokeBEWord16 p a $> plusPtr p 2) + +-- | +-- Encode Word32 in Little-endian. +{-# INLINE [1] lWord32 #-} +lWord32 :: Word32 -> Poke +lWord32 a = + Poke (\p -> PrimIO.pokeLEWord32 p a $> plusPtr p 4) + +-- | +-- Encode Word32 in Big-endian. +{-# INLINE [1] bWord32 #-} +bWord32 :: Word32 -> Poke +bWord32 a = + Poke (\p -> PrimIO.pokeBEWord32 p a $> plusPtr p 4) + +-- | +-- Encode Word64 in Little-endian. +{-# INLINE [1] lWord64 #-} +lWord64 :: Word64 -> Poke +lWord64 a = + Poke (\p -> PrimIO.pokeLEWord64 p a $> plusPtr p 8) + +-- | +-- Encode Word64 in Big-endian. +{-# INLINE [1] bWord64 #-} +bWord64 :: Word64 -> Poke +bWord64 a = + Poke (\p -> PrimIO.pokeBEWord64 p a $> plusPtr p 8) + +-- | +-- Encode Int16 in Little-endian. +{-# INLINE lInt16 #-} +lInt16 :: Int16 -> Poke +lInt16 = lWord16 . fromIntegral + +-- | +-- Encode Int16 in Big-endian. +{-# INLINE bInt16 #-} +bInt16 :: Int16 -> Poke +bInt16 = bWord16 . fromIntegral + +-- | +-- Encode Int32 in Little-endian. +{-# INLINE lInt32 #-} +lInt32 :: Int32 -> Poke +lInt32 = lWord32 . fromIntegral + +-- | +-- Encode Int32 in Big-endian. +{-# INLINE bInt32 #-} +bInt32 :: Int32 -> Poke +bInt32 = bWord32 . fromIntegral + +-- | +-- Encode Int64 in Little-endian. +{-# INLINE lInt64 #-} +lInt64 :: Int64 -> Poke +lInt64 = lWord64 . fromIntegral + +-- | +-- Encode Int64 in Big-endian. +{-# INLINE bInt64 #-} +bInt64 :: Int64 -> Poke +bInt64 = bWord64 . fromIntegral + +-- | +-- Encode Text in UTF8. +{-# INLINE textUtf8 #-} +textUtf8 :: Text -> Poke +textUtf8 = Poke . TextCompat.pokeInUtf8 + +-- * ASCII integers + +------------------------- + +-- | +-- Encode Int8 as a signed ASCII decimal. +{-# INLINE [1] int8AsciiDec #-} +int8AsciiDec :: Int8 -> Poke +int8AsciiDec a = + Poke (Ffi.pokeIntInDec (fromIntegral a)) + +-- | +-- Encode Int16 as a signed ASCII decimal. +{-# INLINE [1] int16AsciiDec #-} +int16AsciiDec :: Int16 -> Poke +int16AsciiDec a = + Poke (Ffi.pokeIntInDec (fromIntegral a)) + +-- | +-- Encode Int32 as a signed ASCII decimal. +{-# INLINE [1] int32AsciiDec #-} +int32AsciiDec :: Int32 -> Poke +int32AsciiDec a = + Poke (Ffi.pokeIntInDec (fromIntegral a)) + +-- | +-- Encode Int64 as a signed ASCII decimal. +{-# INLINE [1] int64AsciiDec #-} +int64AsciiDec :: Int64 -> Poke +int64AsciiDec a = + Poke (Ffi.pokeLongLongIntInDec (fromIntegral a)) + +-- | +-- Encode Int as a signed ASCII decimal. +{-# INLINE [1] intAsciiDec #-} +intAsciiDec :: Int -> Poke +intAsciiDec a = + Poke (Ffi.pokeLongLongIntInDec (fromIntegral a)) + +-- | +-- Encode Word8 as an unsigned ASCII decimal. +{-# INLINE [1] word8AsciiDec #-} +word8AsciiDec :: Word8 -> Poke +word8AsciiDec a = + Poke (Ffi.pokeUIntInDec (fromIntegral a)) + +-- | +-- Encode Word16 as an unsigned ASCII decimal. +{-# INLINE [1] word16AsciiDec #-} +word16AsciiDec :: Word16 -> Poke +word16AsciiDec a = + Poke (Ffi.pokeUIntInDec (fromIntegral a)) + +-- | +-- Encode Word32 as an unsigned ASCII decimal. +{-# INLINE [1] word32AsciiDec #-} +word32AsciiDec :: Word32 -> Poke +word32AsciiDec a = + Poke (Ffi.pokeUIntInDec (fromIntegral a)) + +-- | +-- Encode Word64 as an unsigned ASCII decimal. +{-# INLINE [1] word64AsciiDec #-} +word64AsciiDec :: Word64 -> Poke +word64AsciiDec a = + Poke (Ffi.pokeLongLongUIntInDec (fromIntegral a)) + +-- | +-- Encode Word as an unsigned ASCII decimal. +{-# INLINE [1] wordAsciiDec #-} +wordAsciiDec :: Word -> Poke +wordAsciiDec a = + Poke (Ffi.pokeLongLongUIntInDec (fromIntegral a)) + +-- | +-- Encode Double as a signed ASCII decimal. +{-# INLINE doubleAsciiDec #-} +doubleAsciiDec :: Double -> Poke +doubleAsciiDec a = + Poke $ \ptr -> + Ffi.pokeDouble a ptr + & fmap (plusPtr ptr . fromIntegral) + +-- * Low level + +------------------------- + +-- | +-- Having the amount of bytes to be written precomputed, +-- executes an action, +-- which fills the pointer going downward, +-- starting from the pointer that follows the chunk. +-- I.e., you have to decrement the pointer +-- before writing the first byte, +-- decrement it again before writing the second byte and so on. +{-# INLINE sizedReverse #-} +sizedReverse :: Int -> (Ptr Word8 -> IO a) -> Poke +sizedReverse size action = + Poke $ \ptr -> + let afterPtr = + plusPtr ptr size + in action afterPtr $> afterPtr diff --git a/src/library/PtrPoker/Prelude.hs b/src/library/PtrPoker/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/library/PtrPoker/Prelude.hs @@ -0,0 +1,78 @@ +module PtrPoker.Prelude + ( module Exports, + showAsText, + ) +where + +import Control.Applicative as Exports hiding (WrappedArrow (..)) +import Control.Arrow as Exports hiding (first, second) +import Control.Category as Exports +import Control.Concurrent as Exports +import Control.Exception as Exports +import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_) +import Control.Monad.Fail as Exports +import Control.Monad.Fix as Exports hiding (fix) +import Control.Monad.IO.Class as Exports +import Control.Monad.ST as Exports +import Data.Bifunctor as Exports +import Data.Bits as Exports +import Data.Bool as Exports +import Data.ByteString as Exports (ByteString) +import Data.Char as Exports +import Data.Coerce as Exports +import Data.Complex as Exports +import Data.Data as Exports +import Data.Dynamic as Exports +import Data.Either as Exports +import Data.Fixed as Exports +import Data.Foldable as Exports hiding (toList) +import Data.Function as Exports hiding (id, (.)) +import Data.Functor as Exports hiding (unzip) +import Data.Functor.Compose as Exports +import Data.IORef as Exports +import Data.Int as Exports +import Data.Ix as Exports +import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons) +import Data.List.NonEmpty as Exports (NonEmpty (..)) +import Data.Maybe as Exports +import Data.Monoid as Exports hiding (Alt, (<>)) +import Data.Ord as Exports +import Data.Proxy as Exports +import Data.Ratio as Exports +import Data.STRef as Exports +import Data.Scientific as Exports (Scientific) +import Data.Semigroup as Exports hiding (First (..), Last (..)) +import Data.String as Exports +import Data.Text as Exports (Text) +import Data.Traversable as Exports +import Data.Tuple as Exports +import Data.Unique as Exports +import Data.Version as Exports +import Data.Void as Exports +import Data.Word as Exports +import Debug.Trace as Exports +import Foreign.ForeignPtr as Exports +import Foreign.Ptr as Exports +import Foreign.StablePtr as Exports +import Foreign.Storable as Exports +import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar) +import GHC.Exts as Exports (ByteArray#, IsList (..), groupWith, inline, lazy, sortWith) +import GHC.Generics as Exports (Generic) +import GHC.IO.Exception as Exports +import GHC.OverloadedLabels as Exports +import Numeric as Exports +import System.Environment as Exports +import System.Exit as Exports +import System.IO as Exports (Handle, hClose) +import System.IO.Error as Exports +import System.IO.Unsafe as Exports +import System.Mem as Exports +import System.Mem.StableName as Exports +import System.Timeout as Exports +import Text.Printf as Exports (hPrintf, printf) +import Text.Read as Exports (Read (..), readEither, readMaybe) +import Unsafe.Coerce as Exports +import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) + +showAsText :: (Show a) => a -> Text +showAsText = show >>> fromString diff --git a/src/library/PtrPoker/Size.hs b/src/library/PtrPoker/Size.hs new file mode 100644 --- /dev/null +++ b/src/library/PtrPoker/Size.hs @@ -0,0 +1,203 @@ +-- | +-- Functions that compute the required allocation size by value. +module PtrPoker.Size where + +import qualified PtrPoker.Compat.Text as TextCompat +import PtrPoker.Prelude + +-- | +-- Efficiently count the amount of bytes required to encode Word64 +-- as a decimal number in ASCII. +-- +-- Implemented as a balanced tree of \"ifs\" +-- centered around the middle of the range. +-- This is much faster than anything based on logarithms. +{-# INLINE word64AsciiDec #-} +word64AsciiDec :: Word64 -> Int +word64AsciiDec x = + if x > 9999999999 + then + if x > 99999999999999 + then + if x > 9999999999999999 + then + if x > 99999999999999999 + then + if x > 999999999999999999 + then + if x > 9999999999999999999 + then 20 + else 19 + else 18 + else 17 + else + if x > 999999999999999 + then 16 + else 15 + else + if x > 999999999999 + then + if x > 9999999999999 + then 14 + else 13 + else + if x > 99999999999 + then 12 + else 11 + else + if x > 99999 + then + if x > 9999999 + then + if x > 99999999 + then + if x > 999999999 + then 10 + else 9 + else 8 + else + if x > 999999 + then 7 + else 6 + else + if x > 99 + then + if x > 999 + then + if x > 9999 + then 5 + else 4 + else 3 + else + if x > 9 + then 2 + else 1 + +-- | +-- Efficiently count the amount of bytes required to encode Int64 +-- as a signed decimal number in ASCII. +-- +-- Implemented as a balanced tree of \"ifs\" +-- centered around the middle of the range. +-- This is much faster than anything based on logarithms. +{-# INLINE int64AsciiDec #-} +int64AsciiDec :: Int64 -> Int +int64AsciiDec x = + if x < 0 + then + if x < -9999999999 + then + if x < -99999999999999 + then + if x < -9999999999999999 + then + if x < -99999999999999999 + then + if x < -999999999999999999 + then 20 + else 19 + else 18 + else + if x < -999999999999999 + then 17 + else 16 + else + if x < -999999999999 + then + if x < -9999999999999 + then 15 + else 14 + else + if x < -99999999999 + then 13 + else 12 + else + if x < -99999 + then + if x < -9999999 + then + if x < -99999999 + then + if x < -999999999 + then 11 + else 10 + else 9 + else + if x < -999999 + then 8 + else 7 + else + if x < -99 + then + if x < -999 + then + if x < -9999 + then 6 + else 5 + else 4 + else + if x < -9 + then 3 + else 2 + else + if x > 9999999999 + then + if x > 99999999999999 + then + if x > 9999999999999999 + then + if x > 99999999999999999 + then + if x > 999999999999999999 + then 19 + else 18 + else 17 + else + if x > 999999999999999 + then 16 + else 15 + else + if x > 999999999999 + then + if x > 9999999999999 + then 14 + else 13 + else + if x > 99999999999 + then 12 + else 11 + else + if x > 99999 + then + if x > 9999999 + then + if x > 99999999 + then + if x > 999999999 + then 10 + else 9 + else 8 + else + if x > 999999 + then 7 + else 6 + else + if x > 99 + then + if x > 999 + then + if x > 9999 + then 5 + else 4 + else 3 + else + if x > 9 + then 2 + else 1 + +-- | +-- Efficiently count the amount of bytes required to encode Text +-- in UTF8. +{-# INLINE textUtf8 #-} +textUtf8 :: Text -> Int +textUtf8 = TextCompat.utf8EncodingSize diff --git a/src/library/PtrPoker/Write.hs b/src/library/PtrPoker/Write.hs new file mode 100644 --- /dev/null +++ b/src/library/PtrPoker/Write.hs @@ -0,0 +1,284 @@ +module PtrPoker.Write where + +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Internal as ByteString +import qualified PtrPoker.ByteString as ByteString +import qualified PtrPoker.Ffi as Ffi +import qualified PtrPoker.Poke as Poke +import PtrPoker.Prelude hiding (concat) +import qualified PtrPoker.Size as Size + +-- | +-- Execute Write, producing strict ByteString. +{-# INLINEABLE toByteString #-} +toByteString :: Write -> ByteString +toByteString Write {..} = + ByteString.unsafeCreate writeSize (void . Poke.pokePtr writePoke) + +-- | +-- Execute Write, producing strict ByteString. +{-# DEPRECATED writeToByteString "Use 'toByteString' instead" #-} +{-# INLINE writeToByteString #-} +writeToByteString :: Write -> ByteString +writeToByteString = toByteString + +-- | +-- Specification of how many bytes to allocate and how to populate them. +-- +-- Useful for creating strict bytestrings and tasks like that. +data Write = Write + { writeSize :: Int, + writePoke :: Poke.Poke + } + +instance Semigroup Write where + {-# INLINE (<>) #-} + Write lSize lPoke <> Write rSize rPoke = + Write (lSize + rSize) (lPoke <> rPoke) + {-# INLINE sconcat #-} + sconcat = + concat + +instance Monoid Write where + {-# INLINE mempty #-} + mempty = + Write 0 mempty + {-# INLINE mconcat #-} + mconcat = + concat + +-- | +-- Reuses the IsString instance of 'ByteString'. +instance IsString Write where + {-# INLINE fromString #-} + fromString = + byteString . fromString + +-- | +-- Force the evaluation of a write. Useful when a complex write is reused +-- multiple times to avoid recomputing its structure. +{-# INLINE force #-} +force :: Write -> Write +force = byteString . toByteString + +-- | +-- Concatenate a foldable of writes. +{-# INLINE concat #-} +concat :: (Foldable f) => f Write -> Write +concat f = + Write + (foldl' (\a b -> a + writeSize b) 0 f) + (Poke.Poke (\p -> foldM (\p write -> Poke.pokePtr (writePoke write) p) p f)) + +-- | +-- Render Word8 as byte. +{-# INLINE word8 #-} +word8 :: Word8 -> Write +word8 a = + Write 1 (Poke.word8 a) + +-- | +-- Render Word16 in Little-endian. +{-# INLINE lWord16 #-} +lWord16 :: Word16 -> Write +lWord16 a = + Write 2 (Poke.lWord16 a) + +-- | +-- Render Word16 in Big-endian. +{-# INLINE bWord16 #-} +bWord16 :: Word16 -> Write +bWord16 a = + Write 2 (Poke.bWord16 a) + +-- | +-- Render Word32 in Little-endian. +{-# INLINE lWord32 #-} +lWord32 :: Word32 -> Write +lWord32 a = + Write 4 (Poke.lWord32 a) + +-- | +-- Render Word32 in Big-endian. +{-# INLINE bWord32 #-} +bWord32 :: Word32 -> Write +bWord32 a = + Write 4 (Poke.bWord32 a) + +-- | +-- Render Word64 in Little-endian. +{-# INLINE lWord64 #-} +lWord64 :: Word64 -> Write +lWord64 a = + Write 8 (Poke.lWord64 a) + +-- | +-- Render Word64 in Big-endian. +{-# INLINE bWord64 #-} +bWord64 :: Word64 -> Write +bWord64 a = + Write 8 (Poke.bWord64 a) + +-- | +-- Render Int16 in Little-endian. +{-# INLINE lInt16 #-} +lInt16 :: Int16 -> Write +lInt16 a = + Write 2 (Poke.lInt16 a) + +-- | +-- Render Int16 in Big-endian. +{-# INLINE bInt16 #-} +bInt16 :: Int16 -> Write +bInt16 a = + Write 2 (Poke.bInt16 a) + +-- | +-- Render Int32 in Little-endian. +{-# INLINE lInt32 #-} +lInt32 :: Int32 -> Write +lInt32 a = + Write 4 (Poke.lInt32 a) + +-- | +-- Render Int32 in Big-endian. +{-# INLINE bInt32 #-} +bInt32 :: Int32 -> Write +bInt32 a = + Write 4 (Poke.bInt32 a) + +-- | +-- Render Int64 in Little-endian. +{-# INLINE lInt64 #-} +lInt64 :: Int64 -> Write +lInt64 a = + Write 8 (Poke.lInt64 a) + +-- | +-- Render Int64 in Big-endian. +{-# INLINE bInt64 #-} +bInt64 :: Int64 -> Write +bInt64 a = + Write 8 (Poke.bInt64 a) + +-- | +-- Render Word64 in ASCII decimal. +{-# INLINE word64AsciiDec #-} +word64AsciiDec :: Word64 -> Write +word64AsciiDec a = + Write size poke + where + size = + Size.word64AsciiDec a + poke = + Poke.sizedReverse size (Ffi.revPokeUInt64 (fromIntegral a)) + +-- | +-- Render Word in ASCII decimal. +{-# INLINE wordAsciiDec #-} +wordAsciiDec :: Word -> Write +wordAsciiDec = + word64AsciiDec . fromIntegral + +-- | +-- Render Int64 in ASCII decimal. +{-# INLINE int64AsciiDec #-} +int64AsciiDec :: Int64 -> Write +int64AsciiDec a = + Write size poke + where + size = + Size.int64AsciiDec a + poke = + Poke.sizedReverse size (Ffi.revPokeInt64 (fromIntegral a)) + +-- | +-- Render Int in ASCII decimal. +{-# INLINE intAsciiDec #-} +intAsciiDec :: Int -> Write +intAsciiDec = + int64AsciiDec . fromIntegral + +-- | +-- Render double interpreting non-real values, +-- such as @NaN@, @Infinity@, @-Infinity@, +-- as is. +{-# INLINE doubleAsciiDec #-} +doubleAsciiDec :: Double -> Write +doubleAsciiDec a = + if a == 0 + then word8 48 + else + if isNaN a + then "NaN" + else + if isInfinite a + then + if a < 0 + then "-Infinity" + else "Infinity" + else + if a < 0 + then word8 45 <> byteString (ByteString.double (negate a)) + else byteString (ByteString.double a) + +-- | +-- Render double interpreting non real values, +-- such as @NaN@, @Infinity@, @-Infinity@, +-- as zero. +{-# INLINE zeroNonRealDoubleAsciiDec #-} +zeroNonRealDoubleAsciiDec :: Double -> Write +zeroNonRealDoubleAsciiDec a = + if a == 0 || isNaN a || isInfinite a + then word8 48 + else + if a < 0 + then word8 45 <> byteString (ByteString.double (negate a)) + else byteString (ByteString.double a) + +-- | +-- Render Scientific in ASCII decimal. +{-# INLINE scientificAsciiDec #-} +scientificAsciiDec :: Scientific -> Write +scientificAsciiDec = + byteString . ByteString.scientific + +-- | +-- Efficiently copy the contents of ByteString using @memcpy@. +{-# INLINE byteString #-} +byteString :: ByteString -> Write +byteString a = + Write (ByteString.length a) (inline Poke.byteString a) + +-- | +-- Render Text in UTF8. +-- +-- Does pretty much the same as 'Data.Text.Encoding.encodeUtf8', +-- both implementation and performance-wise, +-- while allowing you to avoid redundant @memcpy@ +-- compared to @('byteString' . 'Data.Text.Encoding.encodeUtf8')@. +-- +-- Following are the benchmark results comparing the performance of +-- @('toByteString' . 'textUtf8')@ with +-- @Data.Text.Encoding.'Data.Text.Encoding.encodeUtf8'@ +-- on inputs in Latin and Greek (requiring different number of surrogate bytes). +-- The results show that they are quite similar. +-- +-- === __Benchmark results__ +-- +-- > textUtf8/ptr-poker/latin/1 25.61 ns +-- > textUtf8/ptr-poker/latin/10 31.59 ns +-- > textUtf8/ptr-poker/latin/100 121.5 ns +-- > textUtf8/ptr-poker/greek/1 28.54 ns +-- > textUtf8/ptr-poker/greek/10 41.97 ns +-- > textUtf8/ptr-poker/greek/100 250.3 ns +-- > textUtf8/text/latin/1 22.84 ns +-- > textUtf8/text/latin/10 31.10 ns +-- > textUtf8/text/latin/100 118.2 ns +-- > textUtf8/text/greek/1 25.80 ns +-- > textUtf8/text/greek/10 40.80 ns +-- > textUtf8/text/greek/100 293.1 ns +{-# INLINEABLE textUtf8 #-} +textUtf8 :: Text -> Write +textUtf8 a = + Write (Size.textUtf8 a) (Poke.textUtf8 a) diff --git a/src/test/Main.hs b/src/test/Main.hs new file mode 100644 --- /dev/null +++ b/src/test/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/src/test/SizeSpec.hs b/src/test/SizeSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/SizeSpec.hs @@ -0,0 +1,40 @@ +{-# OPTIONS_GHC -Wno-missing-signatures #-} + +module SizeSpec (spec) where + +import qualified Data.ByteString.Char8 as Char8ByteString +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextEncoding +import qualified PtrPoker.Size as Size +import Test.Hspec +import Test.QuickCheck +import Prelude + +spec :: Spec +spec = do + describe "Size" $ do + describe "word64AsciiDec" $ do + it "computes correct size for Word64 ASCII decimal representation" + $ property + $ \a -> Size.word64AsciiDec a === length (show a) + + describe "int64AsciiDec" $ do + it "computes correct size for Int64 ASCII decimal representation" + $ property + $ \a -> Size.int64AsciiDec a === length (show a) + + describe "textUtf8" $ do + it "computes correct size for Text UTF-8 encoding (with unicode)" + $ property + $ \(NonEmpty str) -> + let text = Text.pack str + in Size.textUtf8 text === Char8ByteString.length (TextEncoding.encodeUtf8 text) + + it "computes correct size for Text UTF-8 encoding (ASCII only)" + $ property + $ forAll (getNonEmpty <$> (arbitrary `suchThat` (all isAsciiChar . getNonEmpty))) + $ \str -> + let text = Text.pack str + in Size.textUtf8 text === Char8ByteString.length (TextEncoding.encodeUtf8 text) + where + isAsciiChar c = c <= '\127' diff --git a/src/test/WriteSpec.hs b/src/test/WriteSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/WriteSpec.hs @@ -0,0 +1,167 @@ +{-# OPTIONS_GHC -Wno-missing-signatures #-} + +module WriteSpec (spec) where + +import qualified Data.ByteString.Builder as ByteStringBuilder +import qualified Data.ByteString.Char8 as Char8ByteString +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextEncoding +import IsomorphismClass +import qualified Numeric.Limits as NumericLimits +import qualified PtrPoker.Write as Write +import Test.Hspec +import Test.QuickCheck +import Prelude hiding (choose) + +spec :: Spec +spec = do + describe "Write" $ do + describe "wordAsciiDec" $ do + it "writes Word in ASCII decimal format correctly" + $ property + $ \a -> + let string = Char8ByteString.unpack (Write.toByteString (Write.wordAsciiDec a)) + in read string === a + + describe "intAsciiDec" $ do + it "writes Int in ASCII decimal format correctly" + $ property + $ \a -> + let string = Char8ByteString.unpack (Write.toByteString (Write.intAsciiDec a)) + in read string === a + + describe "doubleAsciiDec" $ do + it "writes Double in ASCII decimal format correctly" + $ property + $ forAll realFloatGen + $ \a -> + let string = Char8ByteString.unpack (Write.toByteString (Write.doubleAsciiDec a)) + in if isNaN a + then string === "NaN" + else read string === a + + describe "zeroNonRealDoubleAsciiDec" $ do + it "writes real Double in ASCII decimal format correctly" + $ property + $ forAll realRealFloatGen + $ \a -> + let string = Char8ByteString.unpack (Write.toByteString (Write.zeroNonRealDoubleAsciiDec a)) + in read string === a + + it "writes non-real Double as 0" + $ property + $ forAll nonRealRealFloatGen + $ \a -> + let string = Char8ByteString.unpack (Write.toByteString (Write.zeroNonRealDoubleAsciiDec a)) + in read @Integer string === 0 + + describe "textUtf8" $ do + it "writes ASCII text correctly" + $ property + $ forAll (getNonEmpty <$> (arbitrary `suchThat` (all isAsciiChar . getNonEmpty))) + $ \str -> + let text = Text.pack str + in Write.toByteString (Write.textUtf8 text) === TextEncoding.encodeUtf8 text + + it "writes UTF-8 text correctly" + $ property + $ \(NonEmpty str) -> + let text = Text.pack str + in Write.toByteString (Write.textUtf8 text) === TextEncoding.encodeUtf8 text + + describe "word8" $ do + it "writes Word8 correctly" + $ property + $ \a -> Write.toByteString (Write.word8 a) === to (ByteStringBuilder.word8 a) + + describe "lWord16" $ do + it "writes Word16 in little-endian format correctly" + $ property + $ \a -> Write.toByteString (Write.lWord16 a) === to (ByteStringBuilder.word16LE a) + + describe "bWord16" $ do + it "writes Word16 in big-endian format correctly" + $ property + $ \a -> Write.toByteString (Write.bWord16 a) === to (ByteStringBuilder.word16BE a) + + describe "lWord32" $ do + it "writes Word32 in little-endian format correctly" + $ property + $ \a -> Write.toByteString (Write.lWord32 a) === to (ByteStringBuilder.word32LE a) + + describe "bWord32" $ do + it "writes Word32 in big-endian format correctly" + $ property + $ \a -> Write.toByteString (Write.bWord32 a) === to (ByteStringBuilder.word32BE a) + + describe "lWord64" $ do + it "writes Word64 in little-endian format correctly" + $ property + $ \a -> Write.toByteString (Write.lWord64 a) === to (ByteStringBuilder.word64LE a) + + describe "bWord64" $ do + it "writes Word64 in big-endian format correctly" + $ property + $ \a -> Write.toByteString (Write.bWord64 a) === to (ByteStringBuilder.word64BE a) + + describe "lInt16" $ do + it "writes Int16 in little-endian format correctly" + $ property + $ \a -> Write.toByteString (Write.lInt16 a) === to (ByteStringBuilder.int16LE a) + + describe "bInt16" $ do + it "writes Int16 in big-endian format correctly" + $ property + $ \a -> Write.toByteString (Write.bInt16 a) === to (ByteStringBuilder.int16BE a) + + describe "lInt32" $ do + it "writes Int32 in little-endian format correctly" + $ property + $ \a -> Write.toByteString (Write.lInt32 a) === to (ByteStringBuilder.int32LE a) + + describe "bInt32" $ do + it "writes Int32 in big-endian format correctly" + $ property + $ \a -> Write.toByteString (Write.bInt32 a) === to (ByteStringBuilder.int32BE a) + + describe "lInt64" $ do + it "writes Int64 in little-endian format correctly" + $ property + $ \a -> Write.toByteString (Write.lInt64 a) === to (ByteStringBuilder.int64LE a) + + describe "bInt64" $ do + it "writes Int64 in big-endian format correctly" + $ property + $ \a -> Write.toByteString (Write.bInt64 a) === to (ByteStringBuilder.int64BE a) + +-- * Generators + +realFloatGen :: Gen Double +realFloatGen = + frequency + [ (99, realRealFloatGen), + (1, nonRealRealFloatGen) + ] + +nonRealRealFloatGen :: Gen Double +nonRealRealFloatGen = + elements [0 / 0, 1 / 0, (-1) / 0, -0.0] + +realRealFloatGen :: Gen Double +realRealFloatGen = + frequency + [ (50, fullRangeExponentialRealFloatGen), + (50, simpleZeroToOneRealFloatGen) + ] + +fullRangeExponentialRealFloatGen :: Gen Double +fullRangeExponentialRealFloatGen = + choose (NumericLimits.minValue, NumericLimits.maxValue) + +simpleZeroToOneRealFloatGen :: Gen Double +simpleZeroToOneRealFloatGen = do + int <- choose (0 :: Int, 999999) + return (read ("0." <> show int)) + +isAsciiChar :: Char -> Bool +isAsciiChar c = c <= '\127' diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# OPTIONS_GHC -Wno-missing-signatures #-} - -module Main where - -import qualified Data.ByteString.Builder as ByteStringBuilder -import qualified Data.ByteString.Char8 as Char8ByteString -import qualified Data.Text.Encoding as Text -import Hedgehog -import qualified Hedgehog.Gen as Gen -import Hedgehog.Main -import qualified Hedgehog.Range as Range -import IsomorphismClass -import qualified Numeric.Limits as NumericLimits -import qualified PtrPoker.Size as Size -import qualified PtrPoker.Write as Write -import Prelude - -main = - defaultMain $ pure $ checkParallel $ $$(discover) - -prop_word64Size = - property $ do - a <- forAll (Gen.word64 (Range.exponential minBound maxBound)) - Size.word64AsciiDec a - === length (show a) - -prop_int64Size = - property $ do - a <- forAll (Gen.int64 (Range.exponential minBound maxBound)) - Size.int64AsciiDec a - === length (show a) - -prop_wordAsciiDec = - property $ do - a <- forAll (Gen.word (Range.exponential minBound maxBound)) - let string = - Char8ByteString.unpack (Write.writeToByteString (Write.wordAsciiDec a)) - annotate string - read string === a - -prop_intAsciiDec = - property $ do - a <- forAll (Gen.int (Range.exponential minBound maxBound)) - let string = - Char8ByteString.unpack (Write.writeToByteString (Write.intAsciiDec a)) - annotate string - read string === a - -prop_doubleAsciiDec = - property $ do - a <- forAll realFloatGen - let string = - Char8ByteString.unpack (Write.writeToByteString (Write.doubleAsciiDec a)) - annotate string - if isNaN a - then string === "NaN" - else read string === a - -prop_realZeroNonRealDoubleAsciiDec = - property $ do - a <- forAll realRealFloatGen - let string = - Char8ByteString.unpack (Write.writeToByteString (Write.zeroNonRealDoubleAsciiDec a)) - annotate string - read string === a - -prop_nonRealZeroNonRealDoubleAsciiDec = - withTests 99 - $ property - $ do - a <- forAll nonRealRealFloatGen - let string = - Char8ByteString.unpack (Write.writeToByteString (Write.zeroNonRealDoubleAsciiDec a)) - annotate string - read @Integer string === 0 - -prop_sizeOfTextUtf8 = - property $ do - a <- forAll (Gen.text (Range.exponential 0 9999) (Gen.choice [Gen.ascii, Gen.unicode])) - Size.textUtf8 a - === Char8ByteString.length (Text.encodeUtf8 a) - -prop_sizeOfTextASCII = - property $ do - a <- forAll (Gen.text (Range.exponential 0 9999) Gen.ascii) - Size.textUtf8 a - === Char8ByteString.length (Text.encodeUtf8 a) - -prop_textASCII = - property $ do - a <- forAll (Gen.text (Range.exponential 0 9999) Gen.ascii) - Write.writeToByteString (Write.textUtf8 a) - === Text.encodeUtf8 a - -prop_textUtf8 = - property $ do - a <- forAll (Gen.text (Range.exponential 0 9999) (Gen.choice [Gen.ascii, Gen.unicode])) - Write.writeToByteString (Write.textUtf8 a) - === Text.encodeUtf8 a - -prop_word8 = - property $ do - a <- forAll (Gen.word8 Range.constantBounded) - Write.writeToByteString (Write.word8 a) - === to (ByteStringBuilder.word8 a) - -prop_lWord16 = - property $ do - a <- forAll (Gen.word16 Range.constantBounded) - Write.writeToByteString (Write.lWord16 a) - === to (ByteStringBuilder.word16LE a) - -prop_bWord16 = - property $ do - a <- forAll (Gen.word16 Range.constantBounded) - Write.writeToByteString (Write.bWord16 a) - === to (ByteStringBuilder.word16BE a) - -prop_lWord32 = - property $ do - a <- forAll (Gen.word32 Range.constantBounded) - Write.writeToByteString (Write.lWord32 a) - === to (ByteStringBuilder.word32LE a) - -prop_bWord32 = - property $ do - a <- forAll (Gen.word32 Range.constantBounded) - Write.writeToByteString (Write.bWord32 a) - === to (ByteStringBuilder.word32BE a) - -prop_lWord64 = - property $ do - a <- forAll (Gen.word64 Range.constantBounded) - Write.writeToByteString (Write.lWord64 a) - === to (ByteStringBuilder.word64LE a) - -prop_bWord64 = - property $ do - a <- forAll (Gen.word64 Range.constantBounded) - Write.writeToByteString (Write.bWord64 a) - === to (ByteStringBuilder.word64BE a) - -prop_lInt16 = - property $ do - a <- forAll (Gen.int16 Range.constantBounded) - Write.writeToByteString (Write.lInt16 a) - === to (ByteStringBuilder.int16LE a) - -prop_bInt16 = - property $ do - a <- forAll (Gen.int16 Range.constantBounded) - Write.writeToByteString (Write.bInt16 a) - === to (ByteStringBuilder.int16BE a) - -prop_lInt32 = - property $ do - a <- forAll (Gen.int32 Range.constantBounded) - Write.writeToByteString (Write.lInt32 a) - === to (ByteStringBuilder.int32LE a) - -prop_bInt32 = - property $ do - a <- forAll (Gen.int32 Range.constantBounded) - Write.writeToByteString (Write.bInt32 a) - === to (ByteStringBuilder.int32BE a) - -prop_lInt64 = - property $ do - a <- forAll (Gen.int64 Range.constantBounded) - Write.writeToByteString (Write.lInt64 a) - === to (ByteStringBuilder.int64LE a) - -prop_bInt64 = - property $ do - a <- forAll (Gen.int64 Range.constantBounded) - Write.writeToByteString (Write.bInt64 a) - === to (ByteStringBuilder.int64BE a) - --- * Gens - -------------------------- - -realFloatGen = - Gen.frequency - [ (99, realRealFloatGen), - (1, nonRealRealFloatGen) - ] - -nonRealRealFloatGen = - Gen.element [0 / 0, 1 / 0, (-1) / 0, -0] - -realRealFloatGen = - Gen.frequency - [ (50, fullRangeExponentialRealFloatGen), - (50, simpleZeroToOneRealFloatGen) - ] - -fullRangeExponentialRealFloatGen = - Gen.realFloat (Range.exponentialFloat NumericLimits.minValue NumericLimits.maxValue) - -simpleZeroToOneRealFloatGen = - do - int <- Gen.int (Range.exponential 0 999999) - return (read ("0." <> show int))