diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2020 Nikita Volkov + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/dtoa.c b/cbits/dtoa.c new file mode 100644 --- /dev/null +++ b/cbits/dtoa.c @@ -0,0 +1,365 @@ +/* +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? + { + for(i = 0; i < decimals; ++i) dst[len-i] = dst[len-i-1]; + dst[len++ - decimals] = '.'; + 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? + { + for(i = 0; i < len; ++i) dst[len-d_exp-1-i] = dst[len-i-1]; + dst[0] = '.'; + for(i = 1; i < -d_exp; ++i) dst[i] = '0'; + len += -d_exp; + } + // 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 new file mode 100644 --- /dev/null +++ b/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/cbits/itoa.c b/cbits/itoa.c new file mode 100644 --- /dev/null +++ b/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/library/PtrPoker/ByteString.hs b/library/PtrPoker/ByteString.hs new file mode 100644 --- /dev/null +++ b/library/PtrPoker/ByteString.hs @@ -0,0 +1,38 @@ +module PtrPoker.ByteString +where + +import PtrPoker.Prelude +import Data.ByteString.Internal +import Data.ByteString.Builder.Prim +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextEncoding +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Builder.Extra as Builder +import qualified Data.ByteString.Builder.Scientific as ScientificBuilder +import qualified PtrPoker.Ffi as Ffi + + +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 24 (\ 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 diff --git a/library/PtrPoker/Ffi.hs b/library/PtrPoker/Ffi.hs new file mode 100644 --- /dev/null +++ b/library/PtrPoker/Ffi.hs @@ -0,0 +1,33 @@ +module PtrPoker.Ffi +where + +import PtrPoker.Prelude +import Foreign.C + + +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 diff --git a/library/PtrPoker/IO/ByteString.hs b/library/PtrPoker/IO/ByteString.hs new file mode 100644 --- /dev/null +++ b/library/PtrPoker/IO/ByteString.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE CPP #-} +module PtrPoker.IO.ByteString +where + +import PtrPoker.Prelude +import Data.ByteString.Internal + + +#if MIN_VERSION_bytestring(0,11,0) + +{-# INLINE pokeByteString #-} +pokeByteString :: Ptr Word8 -> ByteString -> IO (Ptr Word8) +pokeByteString ptr (BS fptr length) = + {-# SCC "pokeByteString" #-} + withForeignPtr fptr $ \ bytesPtr -> + memcpy ptr bytesPtr length $> + plusPtr ptr length + +#else + +{-# INLINE pokeByteString #-} +pokeByteString :: Ptr Word8 -> ByteString -> IO (Ptr Word8) +pokeByteString ptr (PS fptr offset length) = + {-# SCC "pokeByteString" #-} + withForeignPtr fptr $ \ bytesPtr -> + memcpy ptr (plusPtr bytesPtr offset) length $> + plusPtr ptr length + +#endif diff --git a/library/PtrPoker/IO/Prim.hs b/library/PtrPoker/IO/Prim.hs new file mode 100644 --- /dev/null +++ b/library/PtrPoker/IO/Prim.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE CPP #-} +module PtrPoker.IO.Prim +where + +import PtrPoker.Prelude +import qualified PtrPoker.UncheckedShifting as UncheckedShifting + + +{-# 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 value = + {-# SCC "pokeBEWord16" #-} + do + pokeStorable ptr (fromIntegral (UncheckedShifting.shiftr_w16 value 8) :: Word8) + pokeByteOff ptr 1 (fromIntegral value :: Word8) +#endif + +{-# INLINE pokeBEWord32 #-} +pokeBEWord32 :: Ptr Word8 -> Word32 -> IO () +#ifdef WORDS_BIGENDIAN +pokeBEWord32 = + {-# SCC "pokeBEWord32" #-} + pokeStorable +#else +pokeBEWord32 ptr value = + {-# SCC "pokeBEWord32" #-} + do + pokeStorable ptr (fromIntegral (UncheckedShifting.shiftr_w32 value 24) :: Word8) + pokeByteOff ptr 1 (fromIntegral (UncheckedShifting.shiftr_w32 value 16) :: Word8) + pokeByteOff ptr 2 (fromIntegral (UncheckedShifting.shiftr_w32 value 8) :: Word8) + pokeByteOff ptr 3 (fromIntegral value :: Word8) +#endif + +{-# INLINE pokeBEWord64 #-} +pokeBEWord64 :: Ptr Word8 -> Word64 -> IO () +#ifdef WORDS_BIGENDIAN +pokeBEWord64 = + {-# SCC "pokeBEWord64" #-} + pokeStorable +#else +#if WORD_SIZE_IN_BITS < 64 +-- +-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to +-- Word32, and write that +-- +pokeBEWord64 ptr value = + {-# SCC "pokeBEWord64" #-} + do + pokeBEWord32 ptr (fromIntegral (UncheckedShifting.shiftr_w64 value 32)) + pokeBEWord32 (plusPtr ptr 4) (fromIntegral value) +#else +pokeBEWord64 ptr value = + {-# SCC "pokeBEWord64" #-} + do + pokeStorable ptr (fromIntegral (UncheckedShifting.shiftr_w64 value 56) :: Word8) + pokeByteOff ptr 1 (fromIntegral (UncheckedShifting.shiftr_w64 value 48) :: Word8) + pokeByteOff ptr 2 (fromIntegral (UncheckedShifting.shiftr_w64 value 40) :: Word8) + pokeByteOff ptr 3 (fromIntegral (UncheckedShifting.shiftr_w64 value 32) :: Word8) + pokeByteOff ptr 4 (fromIntegral (UncheckedShifting.shiftr_w64 value 24) :: Word8) + pokeByteOff ptr 5 (fromIntegral (UncheckedShifting.shiftr_w64 value 16) :: Word8) + pokeByteOff ptr 6 (fromIntegral (UncheckedShifting.shiftr_w64 value 8) :: Word8) + pokeByteOff ptr 7 (fromIntegral value :: Word8) +#endif +#endif + +{-# INLINE pokeLEWord16 #-} +pokeLEWord16 :: Ptr Word8 -> Word16 -> IO () +#ifdef WORDS_BIGENDIAN +pokeLEWord16 p w = + {-# SCC "pokeLEWord16" #-} + do + pokeWord8 p (fromIntegral w) + pokeWord8Off p 1 (fromIntegral (UncheckedShifting.shiftr_w16 w 8)) +#else +pokeLEWord16 = + {-# SCC "pokeLEWord16" #-} + pokeStorable +#endif + +{-# INLINE pokeLEWord32 #-} +pokeLEWord32 :: Ptr Word8 -> Word32 -> IO () +#ifdef WORDS_BIGENDIAN +pokeLEWord32 p w = + {-# SCC "pokeLEWord32" #-} + do + pokeWord8 p (fromIntegral w) + pokeWord8Off p 1 (fromIntegral (UncheckedShifting.shiftr_w32 w 8)) + pokeWord8Off p 2 (fromIntegral (UncheckedShifting.shiftr_w32 w 16)) + pokeWord8Off p 3 (fromIntegral (UncheckedShifting.shiftr_w32 w 24)) +#else +pokeLEWord32 = + {-# SCC "pokeLEWord32" #-} + pokeStorable +#endif + +{-# INLINE pokeLEWord64 #-} +pokeLEWord64 :: Ptr Word8 -> Word64 -> IO () +#ifdef WORDS_BIGENDIAN +#if WORD_SIZE_IN_BITS < 64 +-- +-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to +-- Word32, and write that +-- +pokeLEWord64 p w = + {-# SCC "pokeLEWord64" #-} + do + let b = fromIntegral (UncheckedShifting.shiftr_w64 w 32) :: Word32 + a = fromIntegral w :: Word32 + pokeWord8 p (fromIntegral a) + pokeWord8Off p 1 (fromIntegral (UncheckedShifting.shiftr_w32 a 8)) + pokeWord8Off p 2 (fromIntegral (UncheckedShifting.shiftr_w32 a 16)) + pokeWord8Off p 3 (fromIntegral (UncheckedShifting.shiftr_w32 a 24)) + pokeWord8Off p 4 (fromIntegral b) + pokeWord8Off p 5 (fromIntegral (UncheckedShifting.shiftr_w32 b 8)) + pokeWord8Off p 6 (fromIntegral (UncheckedShifting.shiftr_w32 b 16)) + pokeWord8Off p 7 (fromIntegral (UncheckedShifting.shiftr_w32 b 24)) +#else +pokeLEWord64 p w = + {-# SCC "pokeLEWord64" #-} + do + pokeWord8 p (fromIntegral w) + pokeWord8Off p 1 (fromIntegral (UncheckedShifting.shiftr_w64 w 8)) + pokeWord8Off p 2 (fromIntegral (UncheckedShifting.shiftr_w64 w 16)) + pokeWord8Off p 3 (fromIntegral (UncheckedShifting.shiftr_w64 w 24)) + pokeWord8Off p 4 (fromIntegral (UncheckedShifting.shiftr_w64 w 32)) + pokeWord8Off p 5 (fromIntegral (UncheckedShifting.shiftr_w64 w 40)) + pokeWord8Off p 6 (fromIntegral (UncheckedShifting.shiftr_w64 w 48)) + pokeWord8Off p 7 (fromIntegral (UncheckedShifting.shiftr_w64 w 56)) +#endif +#else +pokeLEWord64 = + {-# SCC "pokeLEWord64" #-} + pokeStorable +#endif diff --git a/library/PtrPoker/Poke.hs b/library/PtrPoker/Poke.hs new file mode 100644 --- /dev/null +++ b/library/PtrPoker/Poke.hs @@ -0,0 +1,138 @@ +module PtrPoker.Poke +where + +import PtrPoker.Prelude hiding (concat) +import qualified PtrPoker.IO.ByteString as ByteStringIO +import qualified PtrPoker.IO.Prim as PrimIO +import qualified PtrPoker.Ffi as Ffi + + +{-# RULES + "foldMap" forall f foldable. foldMap f foldable = + Poke $ \ p -> foldM (\ p (Poke poker) -> poker p) p foldable + #-} + +newtype Poke = + Poke { pokePtr :: Ptr Word8 -> IO (Ptr Word8) } + +instance Semigroup Poke where + {-# INLINE[1] (<>) #-} + Poke lIO <> Poke rIO = + Poke (lIO >=> rIO) + sconcat = + concat + +instance Monoid Poke where + {-# INLINE[1] mempty #-} + mempty = + Poke return + mconcat = + concat + +instance IsString Poke where + fromString = byteString . fromString + +{-# INLINE[1] concat #-} +concat :: Foldable f => f Poke -> Poke +concat pokers = + Poke (\ p -> foldM (\ p (Poke io) -> io p) p pokers) + +{-# INLINE[1] byteString #-} +byteString :: ByteString -> Poke +byteString bs = + Poke $ \ ptr -> ByteStringIO.pokeByteString ptr bs + +{-# INLINE[1] word8 #-} +word8 :: Word8 -> Poke +word8 a = + Poke (\ p -> PrimIO.pokeWord8 p a $> plusPtr p 1) + +{-| Little-endian Word64 poker. -} +{-# INLINE[1] lWord64 #-} +lWord64 :: Word64 -> Poke +lWord64 a = + Poke (\ p -> PrimIO.pokeLEWord64 p a $> plusPtr p 8) + +{-| Big-endian Word64 poker. -} +{-# INLINE[1] bWord64 #-} +bWord64 :: Word64 -> Poke +bWord64 a = + Poke (\ p -> PrimIO.pokeBEWord64 p a $> plusPtr p 8) + + +-- * ASCII integers +------------------------- + +{-# INLINE[1] int8AsciiDec #-} +int8AsciiDec :: Int8 -> Poke +int8AsciiDec a = + Poke (Ffi.pokeIntInDec (fromIntegral a)) + +{-# INLINE[1] int16AsciiDec #-} +int16AsciiDec :: Int16 -> Poke +int16AsciiDec a = + Poke (Ffi.pokeIntInDec (fromIntegral a)) + +{-# INLINE[1] int32AsciiDec #-} +int32AsciiDec :: Int32 -> Poke +int32AsciiDec a = + Poke (Ffi.pokeIntInDec (fromIntegral a)) + +{-# INLINE[1] int64AsciiDec #-} +int64AsciiDec :: Int64 -> Poke +int64AsciiDec a = + Poke (Ffi.pokeLongLongIntInDec (fromIntegral a)) + +{-# INLINE[1] intAsciiDec #-} +intAsciiDec :: Int -> Poke +intAsciiDec a = + Poke (Ffi.pokeLongLongIntInDec (fromIntegral a)) + +{-# INLINE[1] word8AsciiDec #-} +word8AsciiDec :: Word8 -> Poke +word8AsciiDec a = + Poke (Ffi.pokeUIntInDec (fromIntegral a)) + +{-# INLINE[1] word16AsciiDec #-} +word16AsciiDec :: Word16 -> Poke +word16AsciiDec a = + Poke (Ffi.pokeUIntInDec (fromIntegral a)) + +{-# INLINE[1] word32AsciiDec #-} +word32AsciiDec :: Word32 -> Poke +word32AsciiDec a = + Poke (Ffi.pokeUIntInDec (fromIntegral a)) + +{-# INLINE[1] word64AsciiDec #-} +word64AsciiDec :: Word64 -> Poke +word64AsciiDec a = + Poke (Ffi.pokeLongLongUIntInDec (fromIntegral a)) + +{-# INLINE[1] wordAsciiDec #-} +wordAsciiDec :: Word -> Poke +wordAsciiDec a = + Poke (Ffi.pokeLongLongUIntInDec (fromIntegral a)) + +{-# 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. +-} +{-# 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 new file mode 100644 --- /dev/null +++ b/library/PtrPoker/Prelude.hs @@ -0,0 +1,92 @@ +module PtrPoker.Prelude +( + module Exports, + showAsText, +) +where + +-- base +------------------------- +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, mapM_, sequence_, forM_, msum, mapM, sequence, forM) +import Control.Monad.IO.Class as Exports +import Control.Monad.Fail as Exports +import Control.Monad.Fix as Exports hiding (fix) +import Control.Monad.ST as Exports +import Data.Bifunctor as Exports +import Data.Bits as Exports +import Data.Bool as Exports +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 +import Data.Functor.Compose as Exports +import Data.Int as Exports +import Data.IORef as Exports +import Data.Ix as Exports +import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl') +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.Semigroup as Exports hiding (First(..), Last(..)) +import Data.STRef as Exports +import Data.String as Exports +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, withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead) +import GHC.Exts as Exports (IsList(..), lazy, inline, sortWith, groupWith) +import GHC.Generics as Exports (Generic) +import GHC.IO.Exception as Exports +import GHC.OverloadedLabels as Exports +import Numeric as Exports +import Prelude as Exports hiding (fail, concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.)) +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.ParserCombinators.ReadP as Exports (ReadP, readP_to_S, readS_to_P) +import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec) +import Text.Printf as Exports (printf, hPrintf) +import Text.Read as Exports (Read(..), readMaybe, readEither) +import Unsafe.Coerce as Exports + +-- text +------------------------- +import Data.Text as Exports (Text) + +-- bytestring +------------------------- +import Data.ByteString as Exports (ByteString) + +-- scientific +------------------------- +import Data.Scientific as Exports (Scientific) + +showAsText :: Show a => a -> Text +showAsText = show >>> fromString diff --git a/library/PtrPoker/Size.hs b/library/PtrPoker/Size.hs new file mode 100644 --- /dev/null +++ b/library/PtrPoker/Size.hs @@ -0,0 +1,130 @@ +{-| +Functions that compute the required allocation size by value. +-} +module PtrPoker.Size +where + +import PtrPoker.Prelude + + +{-# 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 + +{-# 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 diff --git a/library/PtrPoker/UncheckedShifting.hs b/library/PtrPoker/UncheckedShifting.hs new file mode 100644 --- /dev/null +++ b/library/PtrPoker/UncheckedShifting.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE CPP #-} +-- | +-- Copyright : (c) 2010 Simon Meier +-- +-- Original serialization code from 'Data.Binary.Builder': +-- (c) Lennart Kolmodin, Ross Patterson +-- +-- License : BSD3-style +-- +-- Utilty module defining unchecked shifts. +-- +-- These functions are undefined when the amount being shifted by is +-- greater than the size in bits of a machine Int#.- +-- +module PtrPoker.UncheckedShifting ( + shiftr_w16 + , shiftr_w32 + , shiftr_w64 + , shiftr_w + + , caseWordSize_32_64 + ) where + + +#if !defined(__HADDOCK__) +import GHC.Base +import GHC.Word (Word32(..),Word16(..),Word64(..)) + +#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608 +import GHC.Word (uncheckedShiftRL64#) +#endif +#else +import Data.Word +#endif + +import Prelude +import Foreign + + +------------------------------------------------------------------------ +-- Unchecked shifts + +-- | Right-shift of a 'Word16'. +{-# INLINE shiftr_w16 #-} +shiftr_w16 :: Word16 -> Int -> Word16 + +-- | Right-shift of a 'Word32'. +{-# INLINE shiftr_w32 #-} +shiftr_w32 :: Word32 -> Int -> Word32 + +-- | Right-shift of a 'Word64'. +{-# INLINE shiftr_w64 #-} +shiftr_w64 :: Word64 -> Int -> Word64 + +-- | Right-shift of a 'Word'. +{-# INLINE shiftr_w #-} +shiftr_w :: Word -> Int -> Word +#if WORD_SIZE_IN_BITS < 64 +shiftr_w w s = fromIntegral $ (`shiftr_w32` s) $ fromIntegral w +#else +shiftr_w w s = fromIntegral $ (`shiftr_w64` s) $ fromIntegral w +#endif + +#if !defined(__HADDOCK__) +shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i) +shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) + +#if WORD_SIZE_IN_BITS < 64 +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i) +#else +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i) +#endif + +#else +shiftr_w16 = shiftR +shiftr_w32 = shiftR +shiftr_w64 = shiftR +#endif + + +-- | Select an implementation depending on the bit-size of 'Word's. +-- Currently, it produces a runtime failure if the bitsize is different. +-- This is detected by the testsuite. +{-# INLINE caseWordSize_32_64 #-} +caseWordSize_32_64 :: a -- Value to use for 32-bit 'Word's + -> a -- Value to use for 64-bit 'Word's + -> a +caseWordSize_32_64 f32 f64 = +#if MIN_VERSION_base(4,7,0) + case finiteBitSize (undefined :: Word) of +#else + case bitSize (undefined :: Word) of +#endif + 32 -> f32 + 64 -> f64 + s -> error $ "caseWordSize_32_64: unsupported Word bit-size " ++ show s diff --git a/library/PtrPoker/Write.hs b/library/PtrPoker/Write.hs new file mode 100644 --- /dev/null +++ b/library/PtrPoker/Write.hs @@ -0,0 +1,122 @@ +module PtrPoker.Write +where + +import PtrPoker.Prelude +import qualified PtrPoker.IO.ByteString as ByteStringIO +import qualified PtrPoker.IO.Prim as PrimIO +import qualified PtrPoker.Poke as Poke +import qualified PtrPoker.Size as Size +import qualified PtrPoker.Ffi as Ffi +import qualified PtrPoker.ByteString as ByteString +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Internal as ByteString + + +writeToByteString :: Write -> ByteString +writeToByteString Write{..} = + ByteString.unsafeCreate writeSize (void . Poke.pokePtr writePoke) + +{-| +Specification of how much 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) + +instance Monoid Write where + {-# INLINE mempty #-} + mempty = + Write 0 mempty + +instance IsString Write where + {-# INLINE fromString #-} + fromString = + byteString . fromString + +{-# INLINE word8 #-} +word8 :: Word8 -> Write +word8 a = + Write 1 (Poke.word8 a) + +{-# INLINE word64AsciiDec #-} +word64AsciiDec :: Word64 -> Write +word64AsciiDec a = + Write size poke + where + size = + Size.word64AsciiDec a + poke = + Poke.sizedReverse size (Ffi.revPokeUInt64 (fromIntegral a)) + +{-# INLINE wordAsciiDec #-} +wordAsciiDec :: Word -> Write +wordAsciiDec = + word64AsciiDec . fromIntegral + +{-# INLINE int64AsciiDec #-} +int64AsciiDec :: Int64 -> Write +int64AsciiDec a = + Write size poke + where + size = + Size.int64AsciiDec a + poke = + Poke.sizedReverse size (Ffi.revPokeInt64 (fromIntegral a)) + +{-# 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) + +{-# INLINE scientificAsciiDec #-} +scientificAsciiDec :: Scientific -> Write +scientificAsciiDec = + byteString . ByteString.scientific + +{-# INLINE byteString #-} +byteString :: ByteString -> Write +byteString a = + Write (ByteString.length a) (Poke.byteString a) diff --git a/ptr-poker.cabal b/ptr-poker.cabal new file mode 100644 --- /dev/null +++ b/ptr-poker.cabal @@ -0,0 +1,53 @@ +name: ptr-poker +version: 0.1 +synopsis: Pointer poking action construction and composition toolkit +homepage: https://github.com/nikita-volkov/ptr-poker +bug-reports: https://github.com/nikita-volkov/ptr-poker/issues +author: Nikita Volkov +maintainer: Nikita Volkov +copyright: (c) 2020 Nikita Volkov +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: git://github.com/nikita-volkov/ptr-poker.git + +library + hs-source-dirs: library + default-extensions: BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples, ViewPatterns + default-language: Haskell2010 + exposed-modules: + PtrPoker.Poke + PtrPoker.Write + PtrPoker.Size + other-modules: + PtrPoker.ByteString + PtrPoker.Ffi + PtrPoker.IO.ByteString + PtrPoker.IO.Prim + PtrPoker.Prelude + PtrPoker.UncheckedShifting + c-sources: + cbits/dtoa.c + cbits/int_encoding.c + cbits/itoa.c + build-depends: + base >=4.11 && <5, + bytestring >=0.10 && <0.12, + scientific >=0.3.6.2 && <0.4, + text >=1 && <2 + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: test + default-extensions: BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples, ViewPatterns + default-language: Haskell2010 + main-is: Main.hs + build-depends: + hedgehog >=1.0.3 && <2, + numeric-limits >=0.1 && <0.2, + ptr-poker, + rerebase >=1.10.0.1 && <2 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,98 @@ +module Main where + +import Prelude +import Hedgehog +import Hedgehog.Main +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import qualified Data.ByteString.Char8 as Char8ByteString +import qualified PtrPoker.Write as Write +import qualified PtrPoker.Size as Size +import qualified Numeric.Limits as NumericLimits + + +main = + defaultMain $ pure $ checkParallel $ $$(discover) + +prop_word64Size = + withTests 999 $ + property $ do + a <- forAll (Gen.word64 (Range.exponential minBound maxBound)) + Size.word64AsciiDec a + === length (show a) + +prop_int64Size = + withTests 999 $ + property $ do + a <- forAll (Gen.int64 (Range.exponential minBound maxBound)) + Size.int64AsciiDec a + === length (show a) + +prop_wordAsciiDec = + withTests 999 $ + 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 = + withTests 999 $ + 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 = + withTests 999 $ + 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 = + withTests 999 $ + 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 string === 0 + + +-- * Gens +------------------------- + +realFloatGen = + Gen.frequency [ + (99, realRealFloatGen) + , + (1, nonRealRealFloatGen) + ] + +nonRealRealFloatGen = + Gen.element [0 / 0, 1 / 0, (-1) / 0, -0] + +realRealFloatGen = + Gen.realFloat (Range.exponentialFloat NumericLimits.minValue NumericLimits.maxValue)