From 8195f8b0cb22141d8d130b3b75dc471b22463a6a Mon Sep 17 00:00:00 2001 From: krangelov Date: Fri, 27 Aug 2021 11:31:10 +0200 Subject: [PATCH] support for unbounded integers --- src/runtime/c/pgf/expr.cxx | 34 ++++++++++++++++++++------ src/runtime/c/pgf/expr.h | 3 ++- src/runtime/c/pgf/pgf.h | 21 ++++++++++++++++- src/runtime/c/pgf/printer.cxx | 16 ++++++++++--- src/runtime/c/pgf/printer.h | 2 +- src/runtime/c/pgf/reader.cxx | 5 ++-- src/runtime/haskell/PGF2/Expr.hs | 6 ++--- src/runtime/haskell/PGF2/FFI.hsc | 38 ++++++++++++++++++++++++++---- src/runtime/haskell/pgf2.cabal | 3 +++ src/runtime/haskell/tests/basic.hs | 8 +++++++ 10 files changed, 113 insertions(+), 23 deletions(-) diff --git a/src/runtime/c/pgf/expr.cxx b/src/runtime/c/pgf/expr.cxx index d674310b2..5a9057bdb 100644 --- a/src/runtime/c/pgf/expr.cxx +++ b/src/runtime/c/pgf/expr.cxx @@ -7,10 +7,11 @@ PgfLiteral PgfDBMarshaller::match_lit(PgfUnmarshaller *u, PgfLiteral l) { switch (ref::get_tag(l)) { case PgfLiteralInt::tag: { - return u->lint(ref::untagged(l)->val); + auto lint = ref::untagged(l); + return u->lint(lint->size, lint->val); } case PgfLiteralFlt::tag: { - return u->lflt(ref::untagged(l)->val); + return u->lflt(ref::untagged(l)->val); } case PgfLiteralStr::tag: { return u->lstr(&ref::untagged(l)->val); @@ -285,7 +286,10 @@ void PgfExprParser::token() if (ch == '>') { ch = getc(); token_tag = PGF_TOKEN_RARROW; - } + } else if (isdigit(ch)) { + putc('-'); + goto digit; + } break; case ',': ch = getc(); @@ -329,10 +333,11 @@ void PgfExprParser::token() } while (pgf_is_ident_rest(ch)); token_tag = PGF_TOKEN_IDENT; } else if (isdigit(ch)) { - while (isdigit(ch)) { +digit: + do { putc(ch); ch = getc(); - } + } while (isdigit(ch)); if (ch == '.') { putc(ch); @@ -422,8 +427,23 @@ PgfExpr PgfExprParser::parse_term() return e; } case PGF_TOKEN_INT: { - int n = atoi((const char*) &token_value->text); - PgfLiteral lit = u->lint(n); + size_t size = (token_value->size + LINT_BASE_LOG - 1)/LINT_BASE_LOG; + uintmax_t *value = (uintmax_t *) alloca(size*sizeof(uintmax_t)); + char *p = token_value->text + token_value->size; + for (size_t i = size; i > 0; i--) { + char tmp = *p; *p = 0; + + char *s = p - LINT_BASE_LOG; + if (s < token_value->text) + s = token_value->text; + value[i-1] = (uintmax_t) + (s == token_value->text) ? strtoll(s, NULL, 10) + : strtoull(s, NULL, 10); + + *p = tmp; + p = s; + } + PgfLiteral lit = u->lint(size, value); PgfExpr e = u->elit(lit); u->free_ref(lit); token(); diff --git a/src/runtime/c/pgf/expr.h b/src/runtime/c/pgf/expr.h index d5acdadab..a80826e80 100644 --- a/src/runtime/c/pgf/expr.h +++ b/src/runtime/c/pgf/expr.h @@ -13,7 +13,8 @@ struct PGF_INTERNAL_DECL PgfLiteralStr { struct PGF_INTERNAL_DECL PgfLiteralInt { static const uint8_t tag = 1; - int val; + size_t size; + uintmax_t val[]; } ; struct PGF_INTERNAL_DECL PgfLiteralFlt { diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index 529f24953..d67e5ae23 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -75,6 +75,25 @@ typedef struct { PgfType type; } PgfTypeHypo; +/* Arbitrary size integers are represented as an array of uintmax_t + * values. Each value in the array is at most LINT_BASE-1 big. + * LINT_BASE itself is always 10 ^ LINT_BASE_LOG. */ +#if __WORDSIZE == 8 +#define LINT_BASE 100 +#define LINT_BASE_LOG 2 +#elif __WORDSIZE == 16 +#define LINT_BASE 10000 +#define LINT_BASE_LOG 4 +#elif __WORDSIZE == 32 +#define LINT_BASE 1000000000 +#define LINT_BASE_LOG 9 +#elif __WORDSIZE == 64 +#define LINT_BASE 10000000000000000000 +#define LINT_BASE_LOG 19 +#else +#error "Platforms with the current __WORDSIZE are not supported yet" +#endif + /* The PgfUnmarshaller structure tells the runtime how to create * abstract syntax expressions and types in the heap of * the host language. For instance, when used from Haskell the runtime @@ -105,7 +124,7 @@ struct PgfUnmarshaller { virtual PgfExpr evar(int index)=0; virtual PgfExpr etyped(PgfExpr expr, PgfType typ)=0; virtual PgfExpr eimplarg(PgfExpr expr)=0; - virtual PgfLiteral lint(int v)=0; + virtual PgfLiteral lint(size_t size, uintmax_t *v)=0; virtual PgfLiteral lflt(double v)=0; virtual PgfLiteral lstr(PgfText *v)=0; virtual PgfType dtyp(int n_hypos, PgfTypeHypo *hypos, diff --git a/src/runtime/c/pgf/printer.cxx b/src/runtime/c/pgf/printer.cxx index 854fc0bfe..c6eeb7e3e 100644 --- a/src/runtime/c/pgf/printer.cxx +++ b/src/runtime/c/pgf/printer.cxx @@ -249,15 +249,25 @@ PgfExpr PgfPrinter::eimplarg(PgfExpr expr) return 0; } -PgfLiteral PgfPrinter::lint(int v) +#define xstr(s) str(s) +#define str(s) #s + +PgfLiteral PgfPrinter::lint(size_t size, uintmax_t *v) { - nprintf(16, "%d", v); + if (size == 0) + puts("0"); + else { + nprintf(32, "%jd", v[0]); + for (size_t i = 1; i < size; i++) { + nprintf(32, "%0" xstr(LINT_BASE_LOG) "ju", v[i]); + } + } return 0; } PgfLiteral PgfPrinter::lflt(double v) { - nprintf(16,"%lg",v); + nprintf(32,"%lg",v); return 0; } diff --git a/src/runtime/c/pgf/printer.h b/src/runtime/c/pgf/printer.h index 490e2b8a0..7b8bce5c7 100644 --- a/src/runtime/c/pgf/printer.h +++ b/src/runtime/c/pgf/printer.h @@ -53,7 +53,7 @@ public: virtual PgfExpr evar(int index); virtual PgfExpr etyped(PgfExpr expr, PgfType typ); virtual PgfExpr eimplarg(PgfExpr expr); - virtual PgfLiteral lint(int v); + virtual PgfLiteral lint(size_t size, uintmax_t *v); virtual PgfLiteral lflt(double v); virtual PgfLiteral lstr(PgfText *v); virtual PgfType dtyp(int n_hypos, PgfTypeHypo *hypos, diff --git a/src/runtime/c/pgf/reader.cxx b/src/runtime/c/pgf/reader.cxx index bb348c068..c731bc1bc 100644 --- a/src/runtime/c/pgf/reader.cxx +++ b/src/runtime/c/pgf/reader.cxx @@ -195,8 +195,9 @@ PgfLiteral PgfReader::read_literal() } case PgfLiteralInt::tag: { ref lit_int = - DB::malloc(tag); - lit_int->val = read_int(); + DB::malloc(sizeof(PgfLiteralInt)+sizeof(uintmax_t)); + lit_int->size = 1; + lit_int->val[0] = read_int(); lit = ref::tagged(lit_int); break; } diff --git a/src/runtime/haskell/PGF2/Expr.hs b/src/runtime/haskell/PGF2/Expr.hs index fb211f8f0..b2a4db8bc 100644 --- a/src/runtime/haskell/PGF2/Expr.hs +++ b/src/runtime/haskell/PGF2/Expr.hs @@ -29,7 +29,7 @@ data BindType = data Literal = LStr String -- ^ string constant - | LInt Int -- ^ integer constant + | LInt Integer -- ^ integer constant | LFlt Double -- ^ floating point constant deriving (Eq,Ord,Show) @@ -117,11 +117,11 @@ unStr (EImplArg e) = unStr e unStr _ = Nothing -- | Constructs an expression from integer literal -mkInt :: Int -> Expr +mkInt :: Integer -> Expr mkInt i = ELit (LInt i) -- | Decomposes an expression into integer literal -unInt :: Expr -> Maybe Int +unInt :: Expr -> Maybe Integer unInt (ELit (LInt i)) = Just i unInt (ETyped e ty) = unInt e unInt (EImplArg e) = unInt e diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index d121c00d4..d16f93fca 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -2,6 +2,9 @@ module PGF2.FFI where +import GHC.Exts +import GHC.Prim +import GHC.Integer.Logarithms import Data.Word import Foreign import Foreign.C @@ -231,7 +234,7 @@ foreign import ccall "dynamic" foreign import ccall "wrapper" wrapEImplArgFun :: EImplArgFun -> IO (FunPtr EImplArgFun) -type LIntFun = Ptr PgfUnmarshaller -> CInt -> IO (StablePtr Literal) +type LIntFun = Ptr PgfUnmarshaller -> (#type size_t) -> Ptr (#type uintmax_t) -> IO (StablePtr Literal) foreign import ccall "dynamic" callLIntFun :: FunPtr LIntFun -> LIntFun @@ -291,10 +294,21 @@ marshaller = unsafePerformIO $ do LStr s -> withText s $ \c_s -> do fun <- (#peek PgfUnmarshallerVtbl, lstr) vtbl callLStrFun fun u c_s - LInt n -> do fun <- (#peek PgfUnmarshallerVtbl, lint) vtbl - callLIntFun fun u (fromIntegral n) + LInt n -> let abs_n = abs n + size = I## (integerLogBase## (#const LINT_BASE) abs_n +## 1##) + in allocaArray size $ \c_v -> do + pokeValue c_v (c_v `plusPtr` ((#size uintmax_t) * (size - 1))) + (fromIntegral (signum n)) abs_n + fun <- (#peek PgfUnmarshallerVtbl, lint) vtbl + callLIntFun fun u (fromIntegral size) c_v LFlt d -> do fun <- (#peek PgfUnmarshallerVtbl, lflt) vtbl callLFltFun fun u (realToFrac d) + where + pokeValue c_v p sign abs_n + | c_v == p = poke p (sign * fromIntegral abs_n) + | otherwise = do let (q,r) = quotRem abs_n (#const LINT_BASE) + poke p (fromIntegral r) + pokeValue c_v (p `plusPtr` (- #size uintmax_t)) sign q matchExpr this u c_expr = do vtbl <- (#peek PgfUnmarshaller, vtbl) u @@ -415,8 +429,22 @@ unmarshaller = unsafePerformIO $ do expr <- deRefStablePtr c_expr newStablePtr (EImplArg expr) - unmarshalLInt this c_v = do - newStablePtr (LInt (fromIntegral c_v)) + unmarshalLInt this c_size c_v = do + n <- if c_size == 0 + then return 0 + else do v <- peek (castPtr c_v :: Ptr (#type intmax_t)) + abs_n <- peekValue (c_size-1) + (c_v `plusPtr` (#size uintmax_t)) + (fromIntegral (abs v)) + return (fromIntegral (signum v) * abs_n) + newStablePtr (LInt n) + where + peekValue 0 c_v value = return value + peekValue c_size c_v value = do + v <- peek (castPtr c_v :: Ptr (#type uintmax_t)) + peekValue (c_size-1) + (c_v `plusPtr` (#size uintmax_t)) + (value*(#const LINT_BASE)+fromIntegral v) unmarshalLFlt this c_v = do newStablePtr (LFlt (realToFrac c_v)) diff --git a/src/runtime/haskell/pgf2.cabal b/src/runtime/haskell/pgf2.cabal index 4ac762d06..b9f0cbb8f 100644 --- a/src/runtime/haskell/pgf2.cabal +++ b/src/runtime/haskell/pgf2.cabal @@ -30,6 +30,8 @@ library PGF2.Expr, PGF2.Type build-depends: + integer-gmp, + ghc-prim, base >= 4.3 && < 4.16, containers, pretty, @@ -48,4 +50,5 @@ test-suite basic build-depends: base, HUnit, + random, pgf2 diff --git a/src/runtime/haskell/tests/basic.hs b/src/runtime/haskell/tests/basic.hs index 392039f05..ce8d6ad17 100644 --- a/src/runtime/haskell/tests/basic.hs +++ b/src/runtime/haskell/tests/basic.hs @@ -1,3 +1,4 @@ +import System.Random import Control.Exception import Test.HUnit import PGF2 @@ -6,6 +7,11 @@ main = do x <- testLoadFailure "non-existing.pgf" y <- testLoadFailure "tests/basic.gf" gr <- readPGF "tests/basic.pgf" + + g <- newStdGen + let limit = 10 ^ 100 + ns = take 5000 (randomRs (-limit,limit) g) + runTestTTAndExit $ TestList [TestCase (assertBool "missing file" x) ,TestCase (assertBool "frong file format" y) @@ -59,6 +65,8 @@ main = do ,TestCase (assertEqual "fresh variables 1" "\\v,v1->v1" (showExpr [] (EAbs Explicit "v" (EAbs Explicit "v" (EVar 0))))) ,TestCase (assertEqual "fresh variables 2" "\\v,v1->v" (showExpr [] (EAbs Explicit "v" (EAbs Explicit "v" (EVar 1))))) ,TestCase (assertEqual "fresh variables 3" "\\v,v1,v2->v1" (showExpr [] (EAbs Explicit "v" (EAbs Explicit "v" (EAbs Explicit "v" (EVar 1)))))) + ,TestCase (assertBool "large integer 1" (null [n | n <- ns, showExpr [] (ELit (LInt n)) /= show n])) + ,TestCase (assertBool "large integer 2" (null [n | n <- ns, readExpr (show n) /= Just (ELit (LInt n))])) ] testLoadFailure fpath = do