diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for mason + +## 0 -- 2019-12-05 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019, Fumiaki Kinoshita + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Fumiaki Kinoshita nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 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/mason.cabal b/mason.cabal new file mode 100644 --- /dev/null +++ b/mason.cabal @@ -0,0 +1,30 @@ +cabal-version: 2.4 + +name: mason +version: 0 +synopsis: Fast and extensible bytestring builder +description: See README.md +bug-reports: https://github.com/fumieval/mason/issues +license: BSD-3-Clause +license-file: LICENSE +author: Fumiaki Kinoshita +maintainer: fumiexcel@gmail.com +copyright: 2019 Fumiaki Kinoshita, Don Stewart 2005-2009, Duncan Coutts 2006-2015, David Roundy 2003-2005, Jasper Van der Jeugt 2010, Simon Meier 2010-2013, Ben Gamari 2017 +category: Data +extra-source-files: CHANGELOG.md + +library + exposed-modules: + Mason.Builder + Mason.Builder.Internal + + c-sources: cbits/dtoa.c + ghc-options: -Wall -O2 + build-depends: base >= 4.12.0.0 && <5 + , bytestring + , text + , network >= 2.7 && <3.2 + , integer-gmp + , ghc-prim + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/Mason/Builder.hs b/src/Mason/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Mason/Builder.hs @@ -0,0 +1,523 @@ +{-# LANGUAGE MagicHash, CPP, UnboxedTuples #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE RankNTypes #-} +module Mason.Builder + ( Builder + , BuilderFor + , Buildable + -- * Runners + , toStrictByteString + , toLazyByteString + , hPutBuilderLen + , hPutBuilder + , sendBuilder + -- * Raw + , flush + , encodeUtf8Builder + , encodeUtf8BuilderEscaped + , byteString + , lazyByteString + , shortByteString + , int8 + , word8 + , int16LE + , int32LE + , int64LE + , word16LE + , word32LE + , word64LE + , floatLE + , doubleLE + , int16BE + , int32BE + , int64BE + , word16BE + , word32BE + , word64BE + , floatBE + , doubleBE + , char7 + , string7 + , char8 + , string8 + , charUtf8 + , stringUtf8 + , floatDec + , doubleDec + , word8Dec + , word16Dec + , word32Dec + , word64Dec + , wordDec + , int8Dec + , int16Dec + , int32Dec + , int64Dec + , intDec + , integerDec + , word8Hex + , word16Hex + , word32Hex + , word64Hex + , wordHex + , int8HexFixed + , int16HexFixed + , int32HexFixed + , int64HexFixed + , word8HexFixed + , word16HexFixed + , word32HexFixed + , word64HexFixed + , floatHexFixed + , doubleHexFixed + , byteStringHex + , lazyByteStringHex + -- * Advanced + , primFixed + , primBounded + , lengthPrefixedWithin + ) where + +import Control.Monad +import Data.Bits +import Data.Word +import Data.Int +import qualified Data.Text as T +import Foreign.C.Types +import Foreign.Ptr (Ptr, plusPtr) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Mason.Builder.Internal as B +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Builder.Prim.Internal as P +import GHC.Integer.GMP.Internals +import GHC.Types (Int(..)) +import System.IO (Handle) + +-- | Put the content of a 'Builder' to a 'Handle'. +hPutBuilder :: Handle -> BuilderFor PutBuilderEnv -> IO () +hPutBuilder h b = void $ hPutBuilderLen h b +{-# INLINE hPutBuilder #-} + +lazyByteString :: BL.ByteString -> Builder +lazyByteString = foldMap byteString . BL.toChunks +{-# INLINE lazyByteString #-} + +------------------------------------------------------------------------------ +-- Binary encodings +------------------------------------------------------------------------------ + +-- | Encode a single signed byte as-is. +-- +{-# INLINE int8 #-} +int8 :: Int8 -> Builder +int8 = B.primFixed P.int8 + +-- | Encode a single unsigned byte as-is. +-- +{-# INLINE word8 #-} +word8 :: Word8 -> Builder +word8 = B.primFixed P.word8 + + +------------------------------------------------------------------------------ +-- Binary little-endian encodings +------------------------------------------------------------------------------ + +-- | Encode an 'Int16' in little endian format. +{-# INLINE int16LE #-} +int16LE :: Int16 -> Builder +int16LE = B.primFixed P.int16LE + +-- | Encode an 'Int32' in little endian format. +{-# INLINE int32LE #-} +int32LE :: Int32 -> Builder +int32LE = B.primFixed P.int32LE + +-- | Encode an 'Int64' in little endian format. +{-# INLINE int64LE #-} +int64LE :: Int64 -> Builder +int64LE = B.primFixed P.int64LE + +-- | Encode a 'Word16' in little endian format. +{-# INLINE word16LE #-} +word16LE :: Word16 -> Builder +word16LE = B.primFixed P.word16LE + +-- | Encode a 'Word32' in little endian format. +{-# INLINE word32LE #-} +word32LE :: Word32 -> Builder +word32LE = B.primFixed P.word32LE + +-- | Encode a 'Word64' in little endian format. +{-# INLINE word64LE #-} +word64LE :: Word64 -> Builder +word64LE = B.primFixed P.word64LE + +-- | Encode a 'Float' in little endian format. +{-# INLINE floatLE #-} +floatLE :: Float -> Builder +floatLE = B.primFixed P.floatLE + +-- | Encode a 'Double' in little endian format. +{-# INLINE doubleLE #-} +doubleLE :: Double -> Builder +doubleLE = B.primFixed P.doubleLE + + +------------------------------------------------------------------------------ +-- Binary big-endian encodings +------------------------------------------------------------------------------ + +-- | Encode an 'Int16' in big endian format. +{-# INLINE int16BE #-} +int16BE :: Int16 -> Builder +int16BE = B.primFixed P.int16BE + +-- | Encode an 'Int32' in big endian format. +{-# INLINE int32BE #-} +int32BE :: Int32 -> Builder +int32BE = B.primFixed P.int32BE + +-- | Encode an 'Int64' in big endian format. +{-# INLINE int64BE #-} +int64BE :: Int64 -> Builder +int64BE = B.primFixed P.int64BE + +-- | Encode a 'Word16' in big endian format. +{-# INLINE word16BE #-} +word16BE :: Word16 -> Builder +word16BE = B.primFixed P.word16BE + +-- | Encode a 'Word32' in big endian format. +{-# INLINE word32BE #-} +word32BE :: Word32 -> Builder +word32BE = B.primFixed P.word32BE + +-- | Encode a 'Word64' in big endian format. +{-# INLINE word64BE #-} +word64BE :: Word64 -> Builder +word64BE = B.primFixed P.word64BE + +-- | Encode a 'Float' in big endian format. +{-# INLINE floatBE #-} +floatBE :: Float -> Builder +floatBE = B.primFixed P.floatBE + +-- | Encode a 'Double' in big endian format. +{-# INLINE doubleBE #-} +doubleBE :: Double -> Builder +doubleBE = B.primFixed P.doubleBE + +------------------------------------------------------------------------------ +-- ASCII encoding +------------------------------------------------------------------------------ + +-- | Char7 encode a 'Char'. +{-# INLINE char7 #-} +char7 :: Char -> Builder +char7 = B.primFixed P.char7 + +-- | Char7 encode a 'String'. +{-# INLINE string7 #-} +string7 :: String -> Builder +string7 = B.primMapListFixed P.char7 + +------------------------------------------------------------------------------ +-- ISO/IEC 8859-1 encoding +------------------------------------------------------------------------------ + +-- | Char8 encode a 'Char'. +{-# INLINE char8 #-} +char8 :: Char -> Builder +char8 = B.primFixed P.char8 + +-- | Char8 encode a 'String'. +{-# INLINE string8 #-} +string8 :: String -> Builder +string8 = B.primMapListFixed P.char8 + +------------------------------------------------------------------------------ +-- UTF-8 encoding +------------------------------------------------------------------------------ + +-- | UTF-8 encode a 'Char'. +{-# INLINE charUtf8 #-} +charUtf8 :: Char -> Builder +charUtf8 = B.primBounded P.charUtf8 + +-- | Encode 'T.Text' as a UTF-8 byte stream. +encodeUtf8Builder :: T.Text -> Builder +encodeUtf8Builder = B.encodeUtf8BuilderEscaped (P.liftFixedToBounded P.word8) +{-# INLINE encodeUtf8Builder #-} + +-------------------- +-- Unsigned integers +-------------------- + +-- | Decimal encoding of a 'Word8' using the ASCII digits. +{-# INLINE word8Dec #-} +word8Dec :: Word8 -> Builder +word8Dec = B.primBounded P.word8Dec + +-- | Decimal encoding of a 'Word16' using the ASCII digits. +{-# INLINE word16Dec #-} +word16Dec :: Word16 -> Builder +word16Dec = B.primBounded P.word16Dec + +-- | Decimal encoding of a 'Word32' using the ASCII digits. +{-# INLINE word32Dec #-} +word32Dec :: Word32 -> Builder +word32Dec = B.primBounded P.word32Dec + +-- | Decimal encoding of a 'Word64' using the ASCII digits. +{-# INLINE word64Dec #-} +word64Dec :: Word64 -> Builder +word64Dec = B.primBounded P.word64Dec + +-- | Decimal encoding of a 'Word' using the ASCII digits. +{-# INLINE wordDec #-} +wordDec :: Word -> Builder +wordDec = B.primBounded P.wordDec + +-- Floating point numbers +------------------------- + +-- | /Currently slow./ Decimal encoding of an IEEE 'Float'. +{-# INLINE floatDec #-} +floatDec :: Float -> Builder +floatDec = string7 . show + +-- | Decimal encoding of an IEEE 'Double'. +{-# INLINE doubleDec #-} +doubleDec :: Double -> Builder +doubleDec x + | isNaN x = string7 "NaN" + | isInfinite x = if x < 0 then string7 "-Infinity" else string7 "Infinity" + | x < 0 = char7 '-' <> grisu (-x) + | isNegativeZero x = string7 "-0.0" + | x == 0 = string7 "0.0" + | otherwise = grisu x + where + grisu v = B.ensure 24 $ \(B.Buffer end ptr) -> do + n <- dtoa_grisu3 v ptr + return $ B.Buffer end $ plusPtr ptr (fromIntegral n) + +foreign import ccall unsafe "static dtoa_grisu3" + dtoa_grisu3 :: Double -> Ptr Word8 -> IO CInt + +------------------------------------------------------------------------------ +-- Decimal Encoding +------------------------------------------------------------------------------ + +-- Signed integers +------------------ + +-- | Decimal encoding of an 'Int8' using the ASCII digits. +-- +-- e.g. +-- +-- > toLazyByteString (int8Dec 42) = "42" +-- > toLazyByteString (int8Dec (-1)) = "-1" +-- +{-# INLINE int8Dec #-} +int8Dec :: Int8 -> Builder +int8Dec = B.primBounded P.int8Dec + +-- | Decimal encoding of an 'Int16' using the ASCII digits. +{-# INLINE int16Dec #-} +int16Dec :: Int16 -> Builder +int16Dec = B.primBounded P.int16Dec + +-- | Decimal encoding of an 'Int32' using the ASCII digits. +{-# INLINE int32Dec #-} +int32Dec :: Int32 -> Builder +int32Dec = B.primBounded P.int32Dec + +-- | Decimal encoding of an 'Int64' using the ASCII digits. +{-# INLINE int64Dec #-} +int64Dec :: Int64 -> Builder +int64Dec = B.primBounded P.int64Dec + +-- | Decimal encoding of an 'Int' using the ASCII digits. +{-# INLINE intDec #-} +intDec :: Int -> Builder +intDec = B.primBounded P.intDec + + + +------------------------------------------------------------------------------ +-- Hexadecimal Encoding +------------------------------------------------------------------------------ + +-- without lead +--------------- + +-- | Shortest hexadecimal encoding of a 'Word8' using lower-case characters. +{-# INLINE word8Hex #-} +word8Hex :: Word8 -> Builder +word8Hex = B.primBounded P.word8Hex + +-- | Shortest hexadecimal encoding of a 'Word16' using lower-case characters. +{-# INLINE word16Hex #-} +word16Hex :: Word16 -> Builder +word16Hex = B.primBounded P.word16Hex + +-- | Shortest hexadecimal encoding of a 'Word32' using lower-case characters. +{-# INLINE word32Hex #-} +word32Hex :: Word32 -> Builder +word32Hex = B.primBounded P.word32Hex + +-- | Shortest hexadecimal encoding of a 'Word64' using lower-case characters. +{-# INLINE word64Hex #-} +word64Hex :: Word64 -> Builder +word64Hex = B.primBounded P.word64Hex + +-- | Shortest hexadecimal encoding of a 'Word' using lower-case characters. +{-# INLINE wordHex #-} +wordHex :: Word -> Builder +wordHex = B.primBounded P.wordHex + +-- fixed width; leading zeroes +------------------------------ + +-- | Encode a 'Int8' using 2 nibbles (hexadecimal digits). +{-# INLINE int8HexFixed #-} +int8HexFixed :: Int8 -> Builder +int8HexFixed = B.primFixed P.int8HexFixed + +-- | Encode a 'Int16' using 4 nibbles. +{-# INLINE int16HexFixed #-} +int16HexFixed :: Int16 -> Builder +int16HexFixed = B.primFixed P.int16HexFixed + +-- | Encode a 'Int32' using 8 nibbles. +{-# INLINE int32HexFixed #-} +int32HexFixed :: Int32 -> Builder +int32HexFixed = B.primFixed P.int32HexFixed + +-- | Encode a 'Int64' using 16 nibbles. +{-# INLINE int64HexFixed #-} +int64HexFixed :: Int64 -> Builder +int64HexFixed = B.primFixed P.int64HexFixed + +-- | Encode a 'Word8' using 2 nibbles (hexadecimal digits). +{-# INLINE word8HexFixed #-} +word8HexFixed :: Word8 -> Builder +word8HexFixed = B.primFixed P.word8HexFixed + +-- | Encode a 'Word16' using 4 nibbles. +{-# INLINE word16HexFixed #-} +word16HexFixed :: Word16 -> Builder +word16HexFixed = B.primFixed P.word16HexFixed + +-- | Encode a 'Word32' using 8 nibbles. +{-# INLINE word32HexFixed #-} +word32HexFixed :: Word32 -> Builder +word32HexFixed = B.primFixed P.word32HexFixed + +-- | Encode a 'Word64' using 16 nibbles. +{-# INLINE word64HexFixed #-} +word64HexFixed :: Word64 -> Builder +word64HexFixed = B.primFixed P.word64HexFixed + +-- | Encode an IEEE 'Float' using 8 nibbles. +{-# INLINE floatHexFixed #-} +floatHexFixed :: Float -> Builder +floatHexFixed = B.primFixed P.floatHexFixed + +-- | Encode an IEEE 'Double' using 16 nibbles. +{-# INLINE doubleHexFixed #-} +doubleHexFixed :: Double -> Builder +doubleHexFixed = B.primFixed P.doubleHexFixed + +-- | Encode each byte of a 'S.ByteString' using its fixed-width hex encoding. +{-# NOINLINE byteStringHex #-} -- share code +byteStringHex :: B.ByteString -> Builder +byteStringHex = B.primMapByteStringFixed P.word8HexFixed + +-- | Encode each byte of a lazy 'L.ByteString' using its fixed-width hex encoding. +{-# NOINLINE lazyByteStringHex #-} -- share code +lazyByteStringHex :: BL.ByteString -> Builder +lazyByteStringHex = B.primMapLazyByteStringFixed P.word8HexFixed + +#define PAIR(a,b) (# a,b #) + +-- | 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 + +maxPow10 :: Integer +maxPow10 = toInteger $ (10 :: Int) ^ caseWordSize_32_64 (9 :: Int) 18 + +-- | Decimal encoding of an 'Integer' using the ASCII digits. +-- Simon Meier's improved implementation from https://github.com/haskell/bytestring/commit/92f19a5d94761042b44a433d7331107611e4d717 +integerDec :: Integer -> Builder +integerDec (S# i#) = intDec (I# i#) +integerDec i + | i < 0 = B.primFixed P.char8 '-' `mappend` go (-i) + | otherwise = go ( i) + where + errImpossible fun = + error $ "integerDec: " ++ fun ++ ": the impossible happened." + + go :: Integer -> Builder + go n | n < maxPow10 = intDec (fromInteger n) + | otherwise = + case putH (splitf (maxPow10 * maxPow10) n) of + (x:xs) -> intDec x `mappend` B.primMapListBounded intDecPadded xs + [] -> errImpossible "integerDec: go" + + splitf :: Integer -> Integer -> [Integer] + splitf pow10 n0 + | pow10 > n0 = [n0] + | otherwise = splith (splitf (pow10 * pow10) n0) + where + splith [] = errImpossible "splith" + splith (n:ns) = + case n `quotRemInteger` pow10 of + PAIR(q,r) | q > 0 -> q : r : splitb ns + | otherwise -> r : splitb ns + + splitb [] = [] + splitb (n:ns) = case n `quotRemInteger` pow10 of + PAIR(q,r) -> q : r : splitb ns + + putH :: [Integer] -> [Int] + putH [] = errImpossible "putH" + putH (n:ns) = case n `quotRemInteger` maxPow10 of + PAIR(x,y) + | q > 0 -> q : r : putB ns + | otherwise -> r : putB ns + where q = fromInteger x + r = fromInteger y + + putB :: [Integer] -> [Int] + putB [] = [] + putB (n:ns) = case n `quotRemInteger` maxPow10 of + PAIR(q,r) -> fromInteger q : fromInteger r : putB ns + +foreign import ccall unsafe "static _hs_bytestring_int_dec_padded9" + c_int_dec_padded9 :: CInt -> Ptr Word8 -> IO () + +foreign import ccall unsafe "static _hs_bytestring_long_long_int_dec_padded18" + c_long_long_int_dec_padded18 :: CLLong -> Ptr Word8 -> IO () + +{-# INLINE intDecPadded #-} +intDecPadded :: P.BoundedPrim Int +intDecPadded = P.liftFixedToBounded $ caseWordSize_32_64 + (P.fixedPrim 9 $ c_int_dec_padded9 . fromIntegral) + (P.fixedPrim 18 $ c_long_long_int_dec_padded18 . fromIntegral) diff --git a/src/Mason/Builder/Internal.hs b/src/Mason/Builder/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Mason/Builder/Internal.hs @@ -0,0 +1,462 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +module Mason.Builder.Internal (Builder + , BuilderFor(..) + , Buildable(..) + , GrowingBuffer(..) + , Buffer(..) + , byteStringCopy + , shortByteString + , toStrictByteString + , Channel(..) + , toLazyByteString + , stringUtf8 + , lengthPrefixedWithin + , primBounded + , primFixed + , primMapListFixed + , primMapListBounded + , primMapByteStringFixed + , primMapLazyByteStringFixed + , hPutBuilderLen + , PutBuilderEnv(..) + , encodeUtf8BuilderEscaped + , sendBuilder + , SocketEnv(..) + , cstring + , cstringUtf8 + -- * Internal + , ensure + , allocateConstant + , grisu3 + ) where + +import Control.Concurrent +import Control.Exception (throw) +import Control.Monad +import Data.Bits ((.&.)) +import qualified Data.ByteString as B +import qualified Data.ByteString.Short.Internal as SB +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Internal as BL +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Builder.Prim.Internal as B +import Data.Text.Internal.Unsafe.Shift (shiftR) +import Data.Text.Internal.Unsafe.Char (ord) +import System.IO +import Foreign.C.Types +import Foreign.Ptr +import Foreign.ForeignPtr.Unsafe +import Foreign.ForeignPtr +import Foreign.Marshal.Array (allocaArray) +import Data.IORef +import Data.Word (Word8) +import Data.String +import qualified Foreign.Storable as S +import System.IO.Unsafe +import qualified Data.Text.Array as A +import qualified Data.Text.Internal as T +import qualified Data.Text.Internal.Encoding.Utf16 as U16 +import qualified Network.Socket as S +import qualified Network.Socket.ByteString as S +import GHC.Prim (eqWord#, plusAddr#, indexWord8OffAddr#) +import GHC.Ptr (Ptr(..)) +import GHC.Word (Word8(..)) +import GHC.Types (isTrue#) +import GHC.Base (unpackCString#, unpackCStringUtf8#, unpackFoldrCString#, build) + +-- | The Builder type. Requires RankNTypes extension +type Builder = forall s. Buildable s => BuilderFor s + +-- | Builder specialised for a backend +newtype BuilderFor s = Builder { unBuilder :: s -> Buffer -> IO Buffer } + +class Buildable s where + -- | Put a 'B.ByteString'. + byteString :: B.ByteString -> BuilderFor s + -- | Flush the content of the internal buffer. + flush :: BuilderFor s + -- | Allocate a buffer with at least the given length. + allocate :: Int -> BuilderFor s + +-- | Buffer pointers +data Buffer = Buffer + { bEnd :: {-# UNPACK #-} !(Ptr Word8) -- ^ end of the buffer (next to the last byte) + , bCur :: {-# UNPACK #-} !(Ptr Word8) -- ^ current position + } + +-- | Copy a 'B.ByteString' to a buffer. +byteStringCopy :: Buildable s => B.ByteString -> BuilderFor s +byteStringCopy = \(B.PS fsrc ofs len) -> ensure len $ \(Buffer end ptr) -> do + withForeignPtr fsrc $ \src -> B.memcpy ptr (src `plusPtr` ofs) len + return $ Buffer end (ptr `plusPtr` len) +{-# INLINE byteStringCopy #-} + +-- | Copy a 'SB.ShortByteString' to a buffer. +shortByteString :: SB.ShortByteString -> Builder +shortByteString = \src -> let len = SB.length src in ensure len $ \(Buffer end ptr) -> + Buffer end (ptr `plusPtr` len) + <$ SB.copyToPtr src 0 ptr len +{-# INLINE shortByteString #-} + +-- | Ensure that the given number of bytes is available in the buffer. Subject to semigroup fusions +ensure :: Int -> (Buffer -> IO Buffer) -> Builder +ensure mlen cont = Builder $ \env buf@(Buffer end ptr) -> + if ptr `plusPtr` mlen >= end + then do + buf'@(Buffer end' ptr') <- unBuilder flush env buf + if mlen <= minusPtr end' ptr' + then cont buf' + else unBuilder (allocate mlen) env buf' >>= cont + else cont buf +{-# INLINE[1] ensure #-} + +{-# RULES "<>/ensure" forall m n f g. ensure m f <> ensure n g = ensure (m + n) (f >=> g) #-} + +-- | Run a builder within a buffer and prefix it by the length. +lengthPrefixedWithin :: Int -- ^ maximum length + -> B.BoundedPrim Int -- ^ prefix encoder + -> BuilderFor () -> Builder +lengthPrefixedWithin maxLen bp builder = ensure (B.sizeBound bp + maxLen) $ \(Buffer end origin) -> do + let base = origin `plusPtr` B.sizeBound bp + Buffer _ base' <- unBuilder builder () (Buffer end base) + let len = minusPtr base' base + newBase <- B.runB bp len origin + c_memmove newBase base len + return $ Buffer end (newBase `plusPtr` len) +{-# INLINE lengthPrefixedWithin #-} + +-- | Work with a constant buffer. 'allocate' will always fail. +instance Buildable () where + byteString = byteStringCopy + {-# INLINE byteString #-} + flush = mempty + {-# INLINE flush #-} + allocate _ = Builder $ \_ _ -> fail "Mason.Builder.Internal.allocate: can't allocate" + {-# INLINE allocate #-} + +instance Semigroup (BuilderFor s) where + Builder f <> Builder g = Builder $ \e -> f e >=> g e + {-# INLINE[1] (<>) #-} + +instance Monoid (BuilderFor a) where + mempty = Builder $ const pure + {-# INLINE mempty #-} + +-- | UTF-8 encode a 'String'. +stringUtf8 :: String -> Builder +stringUtf8 = primMapListBounded P.charUtf8 +{-# INLINE [1] stringUtf8 #-} + +{-# RULES +"stringUtf8/unpackCStringUtf8#" forall s. + stringUtf8 (unpackCStringUtf8# s) = cstringUtf8 (Ptr s) + +"stringUtf8/unpackCString#" forall s. + stringUtf8 (unpackCString# s) = cstring (Ptr s) + +"stringUtf8/unpackFoldrCString#" forall s. + stringUtf8 (build (unpackFoldrCString# s)) = cstring (Ptr s) + #-} + +cstring :: Ptr Word8 -> Builder +cstring (Ptr addr0) = Builder $ step addr0 + where + step addr env br@(Buffer end ptr) + | isTrue# (ch `eqWord#` 0##) = pure br + | ptr == end = unBuilder (ensure 3 $ step addr env) env br + | otherwise = do + S.poke ptr (W8# ch) + let br' = Buffer end (ptr `plusPtr` 1) + step (addr `plusAddr#` 1#) env br' + where + !ch = indexWord8OffAddr# addr 0# +{-# INLINE cstring #-} + +cstringUtf8 :: Ptr Word8 -> Builder +cstringUtf8 (Ptr addr0) = Builder $ step addr0 + where + step addr env br@(Buffer end ptr) + | isTrue# (ch `eqWord#` 0##) = pure br + | ptr == end = unBuilder (ensure 3 $ step addr env) env br + -- NULL is encoded as 0xc0 0x80 + | isTrue# (ch `eqWord#` 0xc0##) + , isTrue# (indexWord8OffAddr# addr 1# `eqWord#` 0x80##) = do + S.poke ptr 0 + step (addr `plusAddr#` 2#) env (Buffer end (ptr `plusPtr` 1)) + | otherwise = do + S.poke ptr (W8# ch) + step (addr `plusAddr#` 1#) env (Buffer end (ptr `plusPtr` 1)) + where + !ch = indexWord8OffAddr# addr 0# +{-# INLINE cstringUtf8 #-} + +instance Buildable s => IsString (BuilderFor s) where + fromString = stringUtf8 + {-# INLINE fromString #-} + +primBounded :: B.BoundedPrim a -> a -> Builder +primBounded bp a = ensure (B.sizeBound bp) + $ \(Buffer end ptr) -> Buffer end <$> B.runB bp a ptr +{-# INLINE primBounded #-} + +primFixed :: B.FixedPrim a -> a -> Builder +primFixed fp a = ensure (B.size fp) + $ \(Buffer end ptr) -> Buffer end (ptr `plusPtr` B.size fp) <$ B.runF fp a ptr +{-# INLINE primFixed #-} + +primMapListFixed :: B.FixedPrim a -> [a] -> Builder +primMapListFixed fp = foldMap (primFixed fp) +{-# INLINE primMapListFixed #-} + +primMapListBounded :: B.BoundedPrim a -> [a] -> Builder +primMapListBounded bp = foldMap (primBounded bp) +{-# INLINE primMapListBounded #-} + +primMapByteStringFixed :: B.FixedPrim Word8 -> B.ByteString -> Builder +primMapByteStringFixed fp = B.foldr (mappend . primFixed fp) mempty +{-# INLINE primMapByteStringFixed #-} + +primMapLazyByteStringFixed :: B.FixedPrim Word8 -> BL.ByteString -> Builder +primMapLazyByteStringFixed fp = BL.foldr (mappend . primFixed fp) mempty +{-# INLINE primMapLazyByteStringFixed #-} + +newtype GrowingBuffer = GrowingBuffer (IORef (ForeignPtr Word8)) + +instance Buildable GrowingBuffer where + byteString = byteStringCopy + {-# INLINE byteString #-} + flush = mempty + {-# INLINE flush #-} + allocate len = Builder $ \(GrowingBuffer bufferRef) (Buffer _ dst) -> do + fptr0 <- readIORef bufferRef + let ptr0 = unsafeForeignPtrToPtr fptr0 + let !pos = dst `minusPtr` ptr0 + let !size' = pos + max len pos + fptr <- mallocForeignPtrBytes size' + let !dst' = unsafeForeignPtrToPtr fptr + B.memcpy dst' ptr0 pos + writeIORef bufferRef fptr + return $ Buffer (dst' `plusPtr` size') (dst' `plusPtr` pos) + {-# INLINE allocate #-} + +toStrictByteString :: BuilderFor GrowingBuffer -> B.ByteString +toStrictByteString b = unsafePerformIO $ do + fptr0 <- mallocForeignPtrBytes initialSize + bufferRef <- newIORef fptr0 + let ptr0 = unsafeForeignPtrToPtr fptr0 + + Buffer _ pos <- unBuilder b (GrowingBuffer bufferRef) + $ Buffer (ptr0 `plusPtr` initialSize) ptr0 + + fptr <- readIORef bufferRef + pure $ B.PS fptr 0 (pos `minusPtr` unsafeForeignPtrToPtr fptr) + + where + initialSize = 128 +{-# INLINE toStrictByteString #-} + +data Channel = Channel + { chResp :: !(MVar B.ByteString) + , chBuffer :: !(IORef (ForeignPtr Word8)) + } + +instance Buildable Channel where + byteString bs + | B.length bs < 4096 = byteStringCopy bs + | otherwise = flush <> Builder (\(Channel v _) b -> b <$ putMVar v bs) + {-# INLINE byteString #-} + flush = Builder $ \(Channel v ref) (Buffer end ptr) -> do + ptr0 <- unsafeForeignPtrToPtr <$> readIORef ref + let len = minusPtr ptr ptr0 + when (len > 0) $ putMVar v $! B.unsafeCreate len $ \dst -> B.memcpy dst ptr0 len + return $! Buffer end ptr0 + {-# INLINE flush #-} + allocate = allocateConstant chBuffer + {-# INLINE allocate #-} + +toLazyByteString :: BuilderFor Channel -> BL.ByteString +toLazyByteString body = unsafePerformIO $ do + resp <- newEmptyMVar + + let initialSize = 4096 + fptr <- mallocForeignPtrBytes initialSize + ref <- newIORef fptr + let ptr = unsafeForeignPtrToPtr fptr + + let final (Left e) = throw e + final (Right _) = putMVar resp B.empty + _ <- flip forkFinally final $ unBuilder (body <> flush) (Channel resp ref) + $ Buffer (ptr `plusPtr` initialSize) ptr + + let go _ = unsafePerformIO $ do + bs <- takeMVar resp + return $! if B.null bs + then BL.empty + else BL.Chunk bs (go ()) + return $ go () +{-# INLINE toLazyByteString #-} + +data PutBuilderEnv = PBE + { pbHandle :: !Handle + , pbBuffer :: !(IORef (ForeignPtr Word8)) + , pbTotal :: !(IORef Int) + } + +-- | Allocate a new buffer. +allocateConstant :: (s -> IORef (ForeignPtr Word8)) -> Int -> BuilderFor s +allocateConstant f len = Builder $ \env (Buffer _ _) -> do + fptr <- mallocForeignPtrBytes len + writeIORef (f env) fptr + let ptr1 = unsafeForeignPtrToPtr fptr + return $! Buffer (ptr1 `plusPtr` len) ptr1 +{-# INLINE allocateConstant #-} + +instance Buildable PutBuilderEnv where + byteString bs + | len > 4096 = mappend flush $ Builder $ \(PBE h _ _) buf -> do + B.hPut h bs + return buf + | otherwise = byteStringCopy bs + where + len = B.length bs + {-# INLINE byteString #-} + + flush = Builder $ \(PBE h ref counter) (Buffer end ptr) -> do + ptr0 <- unsafeForeignPtrToPtr <$> readIORef ref + let len = minusPtr ptr ptr0 + modifyIORef' counter (+len) + hPutBuf h ptr0 len + return $! Buffer end ptr0 + {-# INLINE flush #-} + + allocate = allocateConstant pbBuffer + {-# INLINE allocate #-} + +-- | Write a 'Builder' into a handle and obtain the number of bytes written. +-- 'flush' does not imply actual disk operations. Set 'NoBuffering' if you want +-- it to write the content immediately. +hPutBuilderLen :: Handle -> BuilderFor PutBuilderEnv -> IO Int +hPutBuilderLen h b = do + let initialSize = 4096 + fptr <- mallocForeignPtrBytes initialSize + ref <- newIORef fptr + let ptr = unsafeForeignPtrToPtr fptr + counter <- newIORef 0 + _ <- unBuilder (b <> flush) (PBE h ref counter) (Buffer (ptr `plusPtr` initialSize) ptr) + readIORef counter +{-# INLINE hPutBuilderLen #-} + +data SocketEnv = SE + { seSocket :: !S.Socket + , seBuffer :: !(IORef (ForeignPtr Word8)) + , seCounter :: !(IORef Int) + } + +sendBufRange :: S.Socket -> Ptr Word8 -> Ptr Word8 -> IO () +sendBufRange sock ptr0 ptr1 = go ptr0 where + go p + | p >= ptr1 = return () + | otherwise = do + sent <- S.sendBuf sock p (minusPtr ptr1 p) + S.withFdSocket sock $ threadWaitWrite . fromIntegral + when (sent > 0) $ go $ p `plusPtr` sent + +instance Buildable SocketEnv where + byteString bs + | len > 4096 = mappend flush $ Builder $ \(SE sock _ _) (Buffer end ptr) -> do + S.sendAll sock bs + return $! Buffer end ptr + | otherwise = byteStringCopy bs + where + len = B.length bs + {-# INLINE byteString #-} + + flush = Builder $ \(SE sock ref counter) (Buffer end ptr1) -> do + ptr0 <- unsafeForeignPtrToPtr <$> readIORef ref + sendBufRange sock ptr0 ptr1 + modifyIORef' counter (+minusPtr ptr1 ptr0) + return $! Buffer end ptr0 + {-# INLINE flush #-} + + allocate = allocateConstant seBuffer + +-- | Write a 'Builder' into a handle and obtain the number of bytes written. +sendBuilder :: S.Socket -> BuilderFor SocketEnv -> IO Int +sendBuilder sock b = do + let initialSize = 4096 + fptr <- mallocForeignPtrBytes initialSize + ref <- newIORef fptr + let ptr = unsafeForeignPtrToPtr fptr + counter <- newIORef 0 + _ <- unBuilder (b <> flush) (SE sock ref counter) (Buffer (ptr `plusPtr` initialSize) ptr) + readIORef counter +{-# INLINE sendBuilder #-} + +{-# INLINE encodeUtf8BuilderEscaped #-} + +-- | Encode 'T.Text' with a custom escaping function +encodeUtf8BuilderEscaped :: B.BoundedPrim Word8 -> T.Text -> Builder +encodeUtf8BuilderEscaped be = step where + bound = max 4 $ B.sizeBound be + + step (T.Text arr off len) = Builder $ loop off where + iend = off + len + loop !i0 env !br@(Buffer ope op0) + | i0 >= iend = return br + | outRemaining > 0 = goPartial (i0 + min outRemaining inpRemaining) + | otherwise = unBuilder (ensure bound (loop i0 env)) env br + where + outRemaining = (ope `minusPtr` op0) `div` bound + inpRemaining = iend - i0 + + goPartial !iendTmp = go i0 op0 + where + go !i !op + | i < iendTmp = case A.unsafeIndex arr i of + w | w <= 0x7F -> do + B.runB be (fromIntegral w) op >>= go (i + 1) + | w <= 0x7FF -> do + poke8 0 $ (w `shiftR` 6) + 0xC0 + poke8 1 $ (w .&. 0x3f) + 0x80 + go (i + 1) (op `plusPtr` 2) + | 0xD800 <= w && w <= 0xDBFF -> do + let c = ord $ U16.chr2 w (A.unsafeIndex arr (i+1)) + poke8 0 $ (c `shiftR` 18) + 0xF0 + poke8 1 $ ((c `shiftR` 12) .&. 0x3F) + 0x80 + poke8 2 $ ((c `shiftR` 6) .&. 0x3F) + 0x80 + poke8 3 $ (c .&. 0x3F) + 0x80 + go (i + 2) (op `plusPtr` 4) + | otherwise -> do + poke8 0 $ (w `shiftR` 12) + 0xE0 + poke8 1 $ ((w `shiftR` 6) .&. 0x3F) + 0x80 + poke8 2 $ (w .&. 0x3F) + 0x80 + go (i + 1) (op `plusPtr` 3) + | otherwise = loop i env (Buffer ope op) + where + poke8 :: Integral a => Int -> a -> IO () + poke8 j v = S.poke (op `plusPtr` j) (fromIntegral v :: Word8) + +foreign import ccall unsafe "memmove" + c_memmove :: Ptr Word8 -> Ptr Word8 -> Int -> IO () + +-- | Decimal encoding of a positive 'Double'. +{-# INLINE grisu3 #-} +grisu3 :: Double -> Maybe (B.ByteString, Int) +grisu3 d = unsafeDupablePerformIO $ allocaArray 2 $ \plen -> do + fptr <- B.mallocByteString 18 + let pexp = plusPtr plen (S.sizeOf (undefined :: CInt)) + success <- withForeignPtr fptr $ \ptr -> c_grisu3 (realToFrac d) ptr plen pexp + if success == 0 + then return Nothing + else do + len <- fromIntegral <$> S.peek plen + e <- fromIntegral <$> S.peek pexp + return $ Just (B.PS fptr 0 len, len + e) + +foreign import ccall unsafe "static grisu3" + c_grisu3 :: CDouble -> Ptr Word8 -> Ptr CInt -> Ptr CInt -> IO CInt