diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,10 +1,6 @@ # Revision history for cborg -## 0.2.4.0 -- 2020-07-05 - -* Performance improvements - -## 0.2.3.0 -- 2020-05-10 +## 0.2.3.1 -- 2020-05-10 * Bounds updates for GHC 8.10 diff --git a/cborg.cabal b/cborg.cabal --- a/cborg.cabal +++ b/cborg.cabal @@ -1,5 +1,5 @@ name: cborg -version: 0.2.4.0 +version: 0.2.5.0 synopsis: Concise Binary Object Representation (CBOR) license: BSD3 license-file: LICENSE.txt @@ -13,7 +13,7 @@ build-type: Simple cabal-version: >= 1.10 tested-with: - GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1 + GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1, GHC == 9.0.1 extra-source-files: ChangeLog.md @@ -83,11 +83,11 @@ build-depends: array >= 0.4 && < 0.6, - base >= 4.7 && < 4.15, - bytestring >= 0.10.4 && < 0.11, + base >= 4.7 && < 4.16, + bytestring >= 0.10.4 && < 0.12, containers >= 0.5 && < 0.7, deepseq >= 1.0 && < 1.5, - ghc-prim >= 0.3.1.0 && < 0.7, + ghc-prim >= 0.3.1.0 && < 0.8, half >= 0.2.2.3 && < 0.4, primitive >= 0.5 && < 0.8, text >= 1.1 && < 1.3 @@ -100,8 +100,12 @@ if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances else - -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8 - build-depends: fail == 4.9.*, semigroups >=0.18 && <0.20 + build-depends: + -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8 + fail == 4.9.*, + semigroups >= 0.18 && < 0.20, + -- the `PS` pattern synonym in bytestring 0.11 is unavailable with GHC < 8.0 + bytestring < 0.11 test-suite tests type: exitcode-stdio-1.0 @@ -134,20 +138,20 @@ build-depends: array >= 0.4 && < 0.6, - base >= 4.7 && < 4.15, + base >= 4.7 && < 4.16, base-orphans, - bytestring >= 0.10.4 && < 0.11, + bytestring >= 0.10.4 && < 0.12, text >= 1.1 && < 1.3, cborg, aeson >= 0.7 && < 1.6, - base64-bytestring >= 1.0 && < 1.2, - base16-bytestring >= 0.1 && < 0.2, + base64-bytestring >= 1.0 && < 1.3, + base16-bytestring >= 1.0 && < 1.1, deepseq >= 1.0 && < 1.5, half >= 0.2.2.3 && < 0.4, QuickCheck >= 2.9 && < 2.15, random, scientific >= 0.3 && < 0.4, - tasty >= 0.11 && < 1.4, + tasty >= 0.11 && < 1.5, tasty-hunit >= 0.9 && < 0.11, tasty-quickcheck >= 0.8 && < 0.11, vector >= 0.10 && < 0.13 diff --git a/src/Codec/CBOR/FlatTerm.hs b/src/Codec/CBOR/FlatTerm.hs --- a/src/Codec/CBOR/FlatTerm.hs +++ b/src/Codec/CBOR/FlatTerm.hs @@ -250,7 +250,7 @@ TypeTag -> do !x <- decodeTag return $! TkTag (fromIntegral x) - TypeTag64 -> do !x <- decodeTag + TypeTag64 -> do !x <- decodeTag64 return $! TkTag (fromIntegral x) TypeBool -> do !x <- decodeBool diff --git a/src/Codec/CBOR/Read.hs b/src/Codec/CBOR/Read.hs --- a/src/Codec/CBOR/Read.hs +++ b/src/Codec/CBOR/Read.hs @@ -9,9 +9,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +#if __GLASGOW_HASKELL__ < 900 -- Bump up from the default 1.5, otherwise our decoder fast path is no good. -- We went over the threshold when we switched to using ST. +-- +-- However, this flag is not supported on GHC 9.0 and later and eye-balling the +-- Core suggests that the new inlining heuristics don't require it. {-# OPTIONS_GHC -funfolding-keeness-factor=2.0 #-} +#endif -- | -- Module : Codec.CBOR.Read diff --git a/src/Codec/CBOR/Write.hs b/src/Codec/CBOR/Write.hs --- a/src/Codec/CBOR/Write.hs +++ b/src/Codec/CBOR/Write.hs @@ -4,7 +4,17 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms #-} +#include "cbor.h" + +#if defined(OPTIMIZE_GMP) +#if __GLASGOW_HASKELL__ >= 900 +#define HAVE_GHC_BIGNUM 1 +{-# LANGUAGE UnboxedSums #-} +#endif +#endif + -- | -- Module : Codec.CBOR.Write -- Copyright : (c) Duncan Coutts 2015-2017 @@ -22,8 +32,6 @@ , toStrictByteString -- :: Encoding -> S.ByteString ) where -#include "cbor.h" - import Data.Bits import Data.Int @@ -44,14 +52,22 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T -#if defined(OPTIMIZE_GMP) import Control.Exception.Base (assert) import GHC.Exts +import GHC.IO (IO(IO)) +#if defined(HAVE_GHC_BIGNUM) +import qualified GHC.Num.Integer +import qualified GHC.Num.BigNat as Gmp +import qualified GHC.Num.BigNat +import GHC.Num.BigNat (BigNat) +#else import qualified GHC.Integer.GMP.Internals as Gmp +import GHC.Integer.GMP.Internals (BigNat) +#endif + #if __GLASGOW_HASKELL__ < 710 import GHC.Word #endif -#endif import qualified Codec.CBOR.ByteArray.Sliced as BAS import Codec.CBOR.Encoding @@ -129,9 +145,10 @@ -- This code is specialized for GMP implementation of Integer. By -- looking directly at the constructors we can avoid some checks. -- S# hold an Int, so we can just use intMP. - TkInteger (Gmp.S# i) vs' -> PI.runB intMP (I# i) op >>= go vs' - -- Jp# is guaranteed to be > 0. - TkInteger integer@(Gmp.Jp# bigNat) vs' + TkInteger (SmallInt i) vs' -> + PI.runB intMP (I# i) op >>= go vs' + -- PosBigInt is guaranteed to be > 0. + TkInteger integer@(PosBigInt bigNat) vs' | integer <= fromIntegral (maxBound :: Word64) -> PI.runB word64MP (fromIntegral integer) op >>= go vs' | otherwise -> @@ -139,7 +156,7 @@ in BI.runBuilderWith (bigNatMP bigNat) (buildStep vs' k) buffer -- Jn# is guaranteed to be < 0. - TkInteger integer@(Gmp.Jn# bigNat) vs' + TkInteger integer@(NegBigInt bigNat) vs' | integer >= -1 - fromIntegral (maxBound :: Word64) -> PI.runB negInt64MP (fromIntegral (-1 - integer)) op >>= go vs' | otherwise -> @@ -181,7 +198,6 @@ bound :: Int bound = 9 - header :: P.BoundedPrim Word8 header = P.liftFixedToBounded P.word8 @@ -579,31 +595,87 @@ -- ---------------------------------------- -- -- Implementation optimized for integer-gmp -- -- ---------------------------------------- -- -bigNatMP :: Gmp.BigNat -> B.Builder + +-- Below is where we try to abstract over the differences between the legacy +-- integer-gmp interface and ghc-bignum, shipped in GHC >= 9.0. + +-- | Write the limbs of a 'BigNat' to the given address in big-endian byte +-- ordering. +exportBigNatToAddr :: BigNat -> Addr# -> IO Word + +#if defined(HAVE_GHC_BIGNUM) + +pattern SmallInt n = GHC.Num.Integer.IS n +pattern PosBigInt n = GHC.Num.Integer.IP n +pattern NegBigInt n = GHC.Num.Integer.IN n + +bigNatSizeInBytes :: GHC.Num.BigNat.BigNat -> Word +bigNatSizeInBytes bigNat = + Gmp.bigNatSizeInBase 256 (GHC.Num.BigNat.unBigNat bigNat) + +bigNatMP :: GHC.Num.BigNat.BigNat# -> B.Builder +bigNatMP n = P.primBounded header 0xc2 <> bigNatToBuilder (GHC.Num.BigNat.BN# n) + +negBigNatMP :: GHC.Num.BigNat.BigNat# -> B.Builder +negBigNatMP n = + -- If value `n` is stored in CBOR, it is interpreted as -1 - n. Since BigNat + -- already represents n (note: it's unsigned), we simply decrement it to get + -- the correct encoding. + P.primBounded header 0xc3 + <> bigNatToBuilder (subtractOneBigNat (GHC.Num.BigNat.BN# n)) + where + subtractOneBigNat (GHC.Num.BigNat.BN# nat) = + case GHC.Num.BigNat.bigNatSubWord# nat 1## of + (# | r #) -> GHC.Num.BigNat.BN# r + (# (# #) | #) -> error "subtractOneBigNat: impossible" + +exportBigNatToAddr (GHC.Num.BigNat.BN# b) addr = IO $ \s -> + -- The last parameter (`1#`) makes the export function use big endian encoding. + case GHC.Num.BigNat.bigNatToAddr# b addr 1# s of + (# s', w #) -> (# s', W# w #) +#else + +pattern SmallInt n = Gmp.S# n +pattern PosBigInt n = Gmp.Jp# n +pattern NegBigInt n = Gmp.Jn# n + +bigNatSizeInBytes :: BigNat -> Word +bigNatSizeInBytes bigNat = W# (Gmp.sizeInBaseBigNat bigNat 256#) + +bigNatMP :: BigNat -> B.Builder bigNatMP n = P.primBounded header 0xc2 <> bigNatToBuilder n -negBigNatMP :: Gmp.BigNat -> B.Builder +negBigNatMP :: BigNat -> B.Builder negBigNatMP n = -- If value `n` is stored in CBOR, it is interpreted as -1 - n. Since BigNat -- already represents n (note: it's unsigned), we simply decrement it to get -- the correct encoding. P.primBounded header 0xc3 - <> bigNatToBuilder (Gmp.minusBigNatWord n (int2Word# 1#)) + <> bigNatToBuilder (subtractOneBigNat n) + where + subtractOneBigNat n = Gmp.minusBigNatWord n (int2Word# 1#) -bigNatToBuilder :: Gmp.BigNat -> B.Builder +exportBigNatToAddr bigNat addr# = + -- The last parameter (`1#`) makes the export function use big endian encoding. + Gmp.exportBigNatToAddr bigNat addr# 1# +#endif + +bigNatToBuilder :: BigNat -> B.Builder bigNatToBuilder = bigNatBuilder where - bigNatBuilder :: Gmp.BigNat -> B.Builder + bigNatBuilder :: BigNat -> B.Builder bigNatBuilder bigNat = - let sizeW# = Gmp.sizeInBaseBigNat bigNat 256# - bounded = PI.boudedPrim (I# (word2Int# sizeW#)) (dumpBigNat sizeW#) - in P.primBounded bytesLenMP (W# sizeW#) <> P.primBounded bounded bigNat + let sizeW = bigNatSizeInBytes bigNat +#if MIN_VERSION_bytestring(0,10,12) + bounded = PI.boundedPrim (fromIntegral sizeW) (dumpBigNat sizeW) +#else + bounded = PI.boudedPrim (fromIntegral sizeW) (dumpBigNat sizeW) +#endif + in P.primBounded bytesLenMP sizeW <> P.primBounded bounded bigNat - dumpBigNat :: Word# -> Gmp.BigNat -> Ptr a -> IO (Ptr a) - dumpBigNat sizeW# bigNat ptr@(Ptr addr#) = do - -- The last parameter (`1#`) makes the export function use big endian - -- encoding. - (W# written#) <- Gmp.exportBigNatToAddr bigNat addr# 1# + dumpBigNat :: Word -> BigNat -> Ptr a -> IO (Ptr a) + dumpBigNat (W# sizeW#) bigNat ptr@(Ptr addr#) = do + (W# written#) <- exportBigNatToAddr bigNat addr# let !newPtr = ptr `plusPtr` (I# (word2Int# written#)) sanity = isTrue# (sizeW# `eqWord#` written#) return $ assert sanity newPtr diff --git a/tests/Tests/Reference/TestVectors.hs b/tests/Tests/Reference/TestVectors.hs --- a/tests/Tests/Reference/TestVectors.hs +++ b/tests/Tests/Reference/TestVectors.hs @@ -44,7 +44,7 @@ encoded <- either fail return $ Base64.decode encoded64 encoded16 <- T.encodeUtf8 <$> obj .: "hex" - let encoded' = fst (Base16.decode encoded16) + let encoded' = Base16.decodeLenient encoded16 when (encoded /= encoded') $ fail "hex and cbor encoding mismatch in input" roundTrip <- obj .: "roundtrip"