serialize.c

/*
 *  Adapted from R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1995--2023  The R Core Team
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, a copy is available at
 *  https://www.R-project.org/Licenses/
 */

#include <R.h>
#include <R_ext/Rdynload.h>
#include <Rinternals.h>
#include <Rversion.h>

#ifdef ENABLE_NLS
#include <libintl.h>
#define _(String) dgettext ("depcache", String)
#else
#define _(String) (String)
#endif

typedef size_t R_size_t;
extern const char *getPRIMNAME(SEXP object); // "for use in packages"

/* ----- V e r s i o n -- T w o -- S a v e / R e s t o r e ----- */

/* Adapted from Chris Young and Ross Ihaka's Version One by Luke
   Tierney.  Copyright Assigned to the R Project.

   The approach used here uses a single pass over the node tree to be
   serialized.  Sharing of reference objects is preserved, but sharing
   among other objects is ignored.  The first time a reference object
   is encountered it is entered in a hash table; the value stored with
   the object is the index in the sequence of reference objects (1 for
   first reference object, 2 for second, etc.).  When an object is
   seen again, i.e. it is already in the hash table, a reference
   marker along with the index is written out.  The unserialize code
   does not know in advance how many reference objects it will see, so
   it starts with an initial array of some reasonable size and doubles
   it each time space runs out.  Reference objects are entered as they
   are encountered.

   This means the serialize and unserialize code needs to agree on
   what is a reference object.  Making a non-reference object into
   a reference object requires a version change in the format.  An
   alternate design would be to precede each reference object with a
   marker that says the next thing is a possibly shared object and
   needs to be entered into the reference table.

   Adding new SXP types is easy, whether they are reference objects or
   not.  The unserialize code will signal an error if it sees a type
   value it does not know.  It is of course better to increment the
   serialization format number when a new SXP is added, but if that
   SXP is unlikely to be saved by users then it may be simpler to keep
   the version number and let the error handling code deal with it.

   The output format for dotted pairs writes the ATTRIB value first
   rather than last.  This allows CDR's to be processed by iterative
   tail calls to avoid recursion stack overflows when processing long
   lists.

   CHARSXPs are now handled in a way that preserves both embedded null
   characters and NA_STRING values.

   The XDR save format now only uses the in-memory xdr facility for
   converting integers and doubles to a portable format.

   The output format packs the type flag and other flags into a single
   integer.  This produces more compact output for code; it has little
   effect on data.

   Environments recognized as package or namespace environments are
   not saved directly. Instead, a STRSXP is saved that is then used to
   attempt to find the package/namespace when unserialized.  The
   exact mechanism for choosing the name and finding the package/name
   space from the name still has to be developed, but the
   serialization format should be able to accommodate any reasonable
   mechanism.

   The mechanism assumes that user code supplies one routine for
   handling single characters and one for handling an array of bytes.
   Higher level interfaces that serialize to/from a FILE * pointer or
   an Rconnection pointer are provided in this file; others can be
   built easily.

   A mechanism is provided to allow special handling of non-system
   reference objects (all weak references and external pointers, and
   all environments other than package environments, namespace
   environments, and the global environment).  The hook function
   consists of a function pointer and a data value.  The serialization
   function pointer is called with the reference object and the data
   value as arguments.  It should return R_NilValue for standard
   handling and an STRSXP for special handling.  If an STRSXP is
   returned, then a special handing mark is written followed by the
   strings in the STRSXP (attributes are ignored).  On unserializing,
   any specially marked entry causes a call to the hook function with
   the reconstructed STRSXP and data value as arguments.  This should
   return the value to use for the reference object.  A reasonable
   convention on how to use this mechanism is needed, but again the
   format should be compatible with any reasonable convention.

   Eventually it may be useful to use these hooks to allow objects
   with a class to have a class-specific serialization mechanism.  The
   serialization format should support this.  It is trickier than in
   Java and other reference based languages where creation and
   initialization can be separated--we don't really have that option
   at the R level.  */


typedef struct {
    void (*OutBytes)(void *, const void *, int), *data;
} shashstream, *hashstream;
static void OutStringVec(hashstream stream, SEXP s, SEXP ref_table);
static void WriteItem (SEXP s, SEXP ref_table, hashstream stream);

/*
 * Utility Functions
 *
 * An assert function which doesn't crash the program.
 * Something like this might be useful in an R header file
 */

#ifdef NDEBUG
#define R_assert(e) ((void) 0)
#else
/* The line below requires an ANSI C preprocessor (stringify operator) */
#define R_assert(e) ((e) ? (void) 0 : error("assertion '%s' failed: file '%s', line %d\n", #e, __FILE__, __LINE__))
#endif /* NDEBUG */

/*
 * Basic Output Routines
 */

static R_INLINE void xdr_int(int i, char buf[sizeof i]) {
#ifdef WORDS_BIGENDIAN
    memcpy(buf, &i, sizeof i);
#else
    // we ought to be using htons, but (1) it won't help with double
    // below and (2) it's too much of a hassle to access it in a
    // portable manner
    const char *src = (const void*)&i;
    for (int i = 1; i <= sizeof i; ++i)
	buf[i-1] = src[sizeof(i) - i];
#endif
}

static R_INLINE void xdr_double(double x, char buf[sizeof x]) {
#ifdef WORDS_BIGENDIAN
    memcpy(buf, &x, sizeof x);
#else
    const char *src = (const void*)&x;
    for (int i = 1; i <= sizeof x; ++i)
	buf[i-1] = src[sizeof(x) - i];
#endif
}

static void OutInteger(hashstream stream, int i)
{
    char buf[sizeof i];
    xdr_int(i, buf);
    stream->OutBytes(stream->data, buf, sizeof buf);
}

static void OutReal(hashstream stream, double d)
{
    if (R_IsNA(d))  d = R_NaReal;
    else if (R_IsNaN(d)) d = R_NaN; // there can be only one
    char buf[sizeof d];
    xdr_double(d, buf);
    stream->OutBytes(stream->data, buf, sizeof buf);
}

static void OutComplex(hashstream stream, Rcomplex c)
{
    OutReal(stream, c.r);
    OutReal(stream, c.i);
}

static void OutByte(hashstream stream, Rbyte i)
{
    stream->OutBytes(stream->data, &i, 1);
}

/* This assumes CHARSXPs remain limited to 2^31-1 bytes */
static void OutString(hashstream stream, const char *s, int length)
{
    stream->OutBytes(stream->data, (void *)s, length);
}

/*
 * Format Header Reading and Writing
 *
 * The header starts with one of three characters, A for ascii, B for
 * binary, or X for xdr.
 */

static void OutFormat(hashstream stream)
{
    stream->OutBytes(stream->data, "X\n", 2);
}

/*
 * Hash Table Functions
 *
 * Hashing functions for hashing reference objects during writing.
 * Objects are entered, and the order in which they are encountered is
 * recorded.  HashGet returns this number, a positive integer, if the
 * object was seen before, and zero if not.  A fixed hash table size
 * is used; this is not ideal but seems adequate for now.  The hash
 * table representation consists of a (R_NilValue . vector) pair.  The
 * hash buckets are in the vector.  This indirect representation
 * should allow resizing the table at some point.
 */

#define HASHSIZE 1099

#define PTRHASH(obj) (((R_size_t) (obj)) >> 2)

#define HASH_TABLE_COUNT(ht) ((int) TRUELENGTH(CDR(ht)))
#define SET_HASH_TABLE_COUNT(ht, val) SET_TRUELENGTH(CDR(ht), ((int) (val)))

#define HASH_TABLE_SIZE(ht) LENGTH(CDR(ht))

#define HASH_BUCKET(ht, pos) VECTOR_ELT(CDR(ht), pos)
#define SET_HASH_BUCKET(ht, pos, val) SET_VECTOR_ELT(CDR(ht), pos, val)

static SEXP MakeHashTable(void)
{
    SEXP val = CONS(R_NilValue, allocVector(VECSXP, HASHSIZE));
    SET_HASH_TABLE_COUNT(val, 0);
    return val;
}

static void HashAdd(SEXP obj, SEXP ht)
{
    R_size_t pos = PTRHASH(obj) % HASH_TABLE_SIZE(ht);
    int count = HASH_TABLE_COUNT(ht) + 1;
    SEXP val = ScalarInteger(count);
    SEXP cell = CONS(val, HASH_BUCKET(ht, pos));

    SET_HASH_TABLE_COUNT(ht, count);
    SET_HASH_BUCKET(ht, pos, cell);
    SET_TAG(cell, obj);
}

static int HashGet(SEXP item, SEXP ht)
{
    R_size_t pos = PTRHASH(item) % HASH_TABLE_SIZE(ht);
    SEXP cell;
    for (cell = HASH_BUCKET(ht, pos); cell != R_NilValue; cell = CDR(cell))
	if (item == TAG(cell))
	    return INTEGER(CAR(cell))[0];
    return 0;
}


/*
 * Administrative SXP values
 *
 * These macros define SXP "type" for specifying special object, such
 * as R_NilValue, or control information, like REFSXP or NAMESPACESXP.
 * The range of SXP types is limited to 5 bit by the current sxpinfo
 * layout, but just in case these values are placed at the top of the
 * 8 bit range.
 */

#define REFSXP            255
#define NILVALUE_SXP      254
#define GLOBALENV_SXP     253
#define UNBOUNDVALUE_SXP  252
#define MISSINGARG_SXP    251
#define BASENAMESPACE_SXP 250
#define NAMESPACESXP      249
#define PACKAGESXP        248
#define PERSISTSXP        247
#define EMPTYENV_SXP	  242
#define BASEENV_SXP	  241

/*
 * Type/Flag Packing and Unpacking
 *
 * To reduce space consumption for serializing code (lots of list
 * structure) the type (at most 8 bits), several single bit flags,
 * and the sxpinfo gp field (LEVELS, 16 bits) are packed into a single
 * integer.  The integer is signed, so this shouldn't be pushed too
 * far.  It assumes at least 28 bits, but that should be no problem.
 */

#define IS_OBJECT_BIT_MASK (1 << 8)
#define HAS_ATTR_BIT_MASK (1 << 9)
#define HAS_TAG_BIT_MASK (1 << 10)
#define ENCODE_LEVELS(v) ((v) << 12)
#define DECODE_LEVELS(v) ((v) >> 12)
#define DECODE_TYPE(v) ((v) & 255)

static int PackFlags(int type, int levs, int isobj, int hasattr, int hastag)
{
    // We ignore LEVELS() because identical() doesn't look at them
    (void)levs;
    int val = type;
    if (isobj) val |= IS_OBJECT_BIT_MASK;
    if (hasattr) val |= HAS_ATTR_BIT_MASK;
    if (hastag) val |= HAS_TAG_BIT_MASK;
    return val;
}

/*
 * Reference/Index Packing and Unpacking
 *
 * Code will contain many references to symbols. As long as there are
 * not too many references, the index ant the REFSXP flag indicating a
 * reference can be packed in a single integer.  Since the index is
 * 1-based, a 0 is used to indicate an index that doesn't fit and
 * therefore follows.
 */

#define PACK_REF_INDEX(i) (((i) << 8) | REFSXP)
#define UNPACK_REF_INDEX(i) ((i) >> 8)
#define MAX_PACKED_INDEX (INT_MAX >> 8)

static void OutRefIndex(hashstream stream, int i)
{
    if (i > MAX_PACKED_INDEX) {
	OutInteger(stream, REFSXP);
	OutInteger(stream, i);
    }
    else OutInteger(stream, PACK_REF_INDEX(i));
}

/*
 * Serialization Code
 */

static int SaveSpecialHook(SEXP item)
{
    if (item == R_NilValue)      return NILVALUE_SXP;
    if (item == R_EmptyEnv)      return EMPTYENV_SXP;
    if (item == R_BaseEnv)       return BASEENV_SXP;
    if (item == R_GlobalEnv)     return GLOBALENV_SXP;
    if (item == R_UnboundValue)  return UNBOUNDVALUE_SXP;
    if (item == R_MissingArg)    return MISSINGARG_SXP;
    if (item == R_BaseNamespace) return BASENAMESPACE_SXP;
    return 0;
}

static void WriteLENGTH(hashstream stream, SEXP s)
{
#ifdef LONG_VECTOR_SUPPORT
    if (IS_LONG_VEC(s)) {
	OutInteger(stream, -1);
	R_xlen_t len = XLENGTH(s);
	OutInteger(stream, (int)(len / 4294967296L));
	OutInteger(stream, (int)(len % 4294967296L));
   } else OutInteger(stream, LENGTH(s));
#else
    OutInteger(stream, LENGTH(s));
#endif
}

#define IF_IC_R_CheckUserInterrupt()		\
    if(!(--ic)) {				\
	R_CheckUserInterrupt();			\
	ic = 9999;				\
    }

static void OutStringVec(hashstream stream, SEXP s, SEXP ref_table)
{
    R_assert(TYPEOF(s) == STRSXP);

#ifdef WARN_ABOUT_NAMES_IN_PERSISTENT_STRINGS
    SEXP names = getAttrib(s, R_NamesSymbol);
    if (names != R_NilValue)
	warning(_("names in persistent strings are currently ignored"));
#endif

    R_xlen_t len = XLENGTH(s);
    OutInteger(stream, 0); /* place holder to allow names if we want to */
    WriteLENGTH(stream, s);
    int ic = 9;
    for (R_xlen_t i = 0; i < len; i++) {
	IF_IC_R_CheckUserInterrupt();
	WriteItem(STRING_ELT(s, i), ref_table, stream);
    }
}

static R_INLINE void
OutIntegerVec(hashstream stream, SEXP s, R_xlen_t length)
{
    int ic = 9999;
    for (R_xlen_t cnt = 0; cnt < length; cnt++) {
	OutInteger(stream, INTEGER(s)[cnt]);
	IF_IC_R_CheckUserInterrupt();
    }
}

static R_INLINE void
OutRealVec(hashstream stream, SEXP s, R_xlen_t length)
{
    int ic = 9999;
    for (R_xlen_t cnt = 0; cnt < length; cnt++) {
	IF_IC_R_CheckUserInterrupt();
	OutReal(stream, REAL(s)[cnt]);
    }
}

static R_INLINE void
OutComplexVec(hashstream stream, SEXP s, R_xlen_t length)
{
    int ic = 9999;
    for (R_xlen_t cnt = 0; cnt < length; cnt++) {
	IF_IC_R_CheckUserInterrupt();
	OutComplex(stream, COMPLEX(s)[cnt]);
    }
}

static SEXP enc2utf8(SEXP el) {
    cetype_t enc = getCharCE(el);
    if (enc == CE_UTF8 || enc == CE_BYTES) return el;
    // ASCII strings will be duplicated, oh well
    return mkCharCE(translateCharUTF8(el), CE_UTF8);
}

static SEXP R_srcrefSymbol, R_wholeSrcrefSymbol, R_srcfileSymbol;
static void WriteItem (SEXP s, SEXP ref_table, hashstream stream)
{
    int ic = 9999;
 tailcall:
    R_CheckStack();
    IF_IC_R_CheckUserInterrupt();

    // sometimes source references just sit there in data structures
    // (e.g. quote(function(){})[[4]]); pretend they don't exist
    if (inherits(s, "srcref")) return;

    int i;
    SEXP t;
    if ((i = SaveSpecialHook(s)) != 0)
	OutInteger(stream, i);
    else if ((i = HashGet(s, ref_table)) != 0)
	OutRefIndex(stream, i);
    else if (TYPEOF(s) == SYMSXP) {
	/* Note : NILSXP can't occur here */
	HashAdd(s, ref_table);
	OutInteger(stream, SYMSXP);
	WriteItem(PRINTNAME(s), ref_table, stream);
    }
    else if (TYPEOF(s) == ENVSXP) {
	HashAdd(s, ref_table);
	if (R_IsPackageEnv(s)) {
	    SEXP name = R_PackageEnvName(s);
	    const void *vmax = vmaxget();
	    warning(_("'%s' may not be available when loading"),
		    translateChar(STRING_ELT(name, 0)));
	    vmaxset(vmax);
	    OutInteger(stream, PACKAGESXP);
	    OutStringVec(stream, name, ref_table);
	}
	else if (R_IsNamespaceEnv(s)) {
#ifdef WARN_ABOUT_NAME_SPACES_MAYBE_NOT_AVAILABLE
	    warning(_("namespaces may not be available when loading"));
#endif
	    OutInteger(stream, NAMESPACESXP);
	    OutStringVec(stream, PROTECT(R_NamespaceEnvSpec(s)), ref_table);
	    UNPROTECT(1);
	}
	else {
	    OutInteger(stream, ENVSXP);
	    OutInteger(stream, R_EnvironmentIsLocked(s) ? 1 : 0);
	    WriteItem(ENCLOS(s), ref_table, stream);
	    WriteItem(FRAME(s), ref_table, stream);
	    WriteItem(HASHTAB(s), ref_table, stream);
	    WriteItem(ATTRIB(s), ref_table, stream);
	}
    }
    else {
	int flags, hastag, hasattr;
	R_xlen_t len;
	int ic = 999;
	switch(TYPEOF(s)) {
	case LISTSXP:
	case LANGSXP:
	case PROMSXP:
	case DOTSXP: hastag = TAG(s) != R_NilValue; break;
	case CLOSXP: hastag = TRUE; break;
	default: hastag = FALSE;
	}
	/* With the CHARSXP cache chains maintained through the ATTRIB
	   field the content of that field must not be serialized, so
	   we treat it as not there. */
	hasattr = (TYPEOF(s) != CHARSXP && ATTRIB(s) != R_NilValue);
	flags = PackFlags(TYPEOF(s), 0, OBJECT(s),
			  hasattr, hastag);
	OutInteger(stream, flags);
	switch (TYPEOF(s)) {
	case LISTSXP:
	case LANGSXP:
	case PROMSXP:
	case DOTSXP:
	    /* Dotted pair objects */
	    /* These write their ATTRIB fields first to allow us to avoid
	       recursion on the CDR */
	    if (hasattr) {
	        SEXP ss = PROTECT(duplicate(s));
	        setAttrib(ss, R_srcrefSymbol, R_NilValue);
	        setAttrib(ss, R_wholeSrcrefSymbol, R_NilValue);
	        setAttrib(ss, R_srcfileSymbol, R_NilValue);
	        WriteItem(ATTRIB(ss), ref_table, stream);
	        UNPROTECT(1);
	    }
	    if (TAG(s) != R_NilValue)
		WriteItem(TAG(s), ref_table, stream);
	    // NOTE: identical() doesn't care about immediate bindings
	    // because those live in environments and those are compared
	    // by pointer value. Can we just ignore this?
#if 0
	    if (BNDCELL_TAG(s))
		R_expand_binding_value(s);
#endif
	    WriteItem(CAR(s), ref_table, stream);
	    /* now do a tail call to WriteItem to handle the CDR */
	    s = CDR(s);
	    goto tailcall;
	case CLOSXP:
	    /* Like a dotted pair object */
	    /* Write the ATTRIB field first to allow us to avoid
	       recursion on the CDR/BODY */
	    if (hasattr)
		WriteItem(ATTRIB(s), ref_table, stream);
	    WriteItem(CLOENV(s), ref_table, stream);
	    WriteItem(FORMALS(s), ref_table, stream);
	    /* now do a tail call to WriteItem to handle the CDR/BODY */
	    s = R_body_no_src(s); // dropping the bytecode
	    goto tailcall;
	case EXTPTRSXP:
	    /* external pointers */
	    HashAdd(s, ref_table);
	    WriteItem(EXTPTR_PROT(s), ref_table, stream);
	    WriteItem(EXTPTR_TAG(s), ref_table, stream);
	    break;
	case WEAKREFSXP:
	    /* Weak references */
	    HashAdd(s, ref_table);
	    break;
	case SPECIALSXP:
	case BUILTINSXP:
	    /* Builtin functions */
	    OutInteger(stream, (int)strlen(getPRIMNAME(s)));
	    OutString(stream, getPRIMNAME(s), (int)strlen(getPRIMNAME(s)));
	    break;
	case CHARSXP:
	    if (s == NA_STRING)
		OutInteger(stream, -1);
	    else {
		SEXP sutf8 = PROTECT(enc2utf8(s));
		OutInteger(stream, LENGTH(sutf8));
		OutString(stream, CHAR(sutf8), LENGTH(sutf8));
		UNPROTECT(1);
	    }
	    break;
	case LGLSXP:
	case INTSXP:
	    len = XLENGTH(s);
	    WriteLENGTH(stream, s);
	    OutIntegerVec(stream, s, len);
	    break;
	case REALSXP:
	    len = XLENGTH(s);
	    WriteLENGTH(stream, s);
	    OutRealVec(stream, s, len);
	    break;
	case CPLXSXP:
	    len = XLENGTH(s);
	    WriteLENGTH(stream, s);
	    OutComplexVec(stream, s, len);
	    break;
	case STRSXP:
	    len = XLENGTH(s);
	    WriteLENGTH(stream, s);
	    for (R_xlen_t ix = 0; ix < len; ix++) {
		IF_IC_R_CheckUserInterrupt();
		WriteItem(STRING_ELT(s, ix), ref_table, stream);
	    }
	    break;
	case VECSXP:
	case EXPRSXP:
	    len = XLENGTH(s);
	    WriteLENGTH(stream, s);
	    for (R_xlen_t ix = 0; ix < len; ix++) {
		IF_IC_R_CheckUserInterrupt();
		WriteItem(VECTOR_ELT(s, ix), ref_table, stream);
	    }
	    break;
	case RAWSXP:
	    len = XLENGTH(s);
	    WriteLENGTH(stream, s);
	    for (R_xlen_t ix = 0; ix < len; ix++) {
		IF_IC_R_CheckUserInterrupt();
		OutByte(stream, RAW(s)[ix]);
	    }
	    break;
#ifdef OBJSXP
	case OBJSXP:
	  break; /* only attributes (i.e., slots) count */
#endif
	default:
	    error(_("WriteItem: unknown type %i"), TYPEOF(s));
	}
	if (hasattr) {
	    s = PROTECT(duplicate(s));
	    setAttrib(s, R_srcrefSymbol, R_NilValue);
	    setAttrib(s, R_wholeSrcrefSymbol, R_NilValue);
	    setAttrib(s, R_srcfileSymbol, R_NilValue);
	    WriteItem(ATTRIB(s), ref_table, stream);
	    s = R_NilValue;
	    UNPROTECT(1);
	}
    }
}

void hash_serialize(SEXP s, void (*outfn)(void*, const void*, int), void *context)
{
    if (!R_srcrefSymbol) R_srcrefSymbol = install("srcref");
    if (!R_wholeSrcrefSymbol) R_wholeSrcrefSymbol = install("wholeSrcref");
    if (!R_srcfileSymbol) R_srcfileSymbol = install("srcfile");
    shashstream stream = {
	.OutBytes = outfn,
	.data = context,
    };
    OutFormat(&stream);

    OutInteger(&stream, 2);
    OutInteger(&stream, R_Version(2,3,0));
    OutInteger(&stream, R_Version(2,3,0));

    SEXP ref_table = PROTECT(MakeHashTable());
    WriteItem(s, ref_table, &stream);
    UNPROTECT(1);
}