Commit 18825f87 authored by Radford Neal's avatar Radford Neal

Merge branch '89' into 89-gradient

parents 6c78fbc3 95d355a0
/*
* pqR : A pretty quick version of R
* Copyright (C) 2013, 2014, 2015, 2016, 2017, 2018 by Radford M. Neal
* Copyright (C) 2013, 2014, 2015, 2016, 2017, 2018, 2019 by Radford M. Neal
*
* Based on R : A Computer Language for Statistical Data Analysis
* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
......@@ -649,7 +649,7 @@ extern void helpers_wait_until_not_in_use(SEXP);
: UPTR_FROM_SEXP(x)->sxpinfo.nmcnt )
#define NAMEDCNT_EQ_0(x) \
( UPTR_FROM_SEXP(x)->sxpinfo.nmcnt == 0 && helpers_is_in_use(x) == 0 ? 1 \
( UPTR_FROM_SEXP(x)->sxpinfo.nmcnt == 0 && !helpers_is_in_use(x) ? 1 \
: UPTR_FROM_SEXP(x)->sxpinfo.nmcnt != 0 ? 0 \
: (helpers_wait_until_not_in_use(x), 1) )
......@@ -657,7 +657,7 @@ extern void helpers_wait_until_not_in_use(SEXP);
( UPTR_FROM_SEXP(x)->sxpinfo.nmcnt == MAX_NAMEDCNT)
#define NAMEDCNT_GT_0(x) \
( UPTR_FROM_SEXP(x)->sxpinfo.nmcnt == 0 && helpers_is_in_use(x) == 0 ? 0 \
( UPTR_FROM_SEXP(x)->sxpinfo.nmcnt == 0 && !helpers_is_in_use(x) ? 0 \
: UPTR_FROM_SEXP(x)->sxpinfo.nmcnt != 0 ? 1 \
: (helpers_wait_until_not_in_use(x), 0) )
......@@ -689,13 +689,6 @@ extern void helpers_wait_until_not_in_use(SEXP);
} while (0)
#endif
/* Macros for compatibility with later R Core versions. */
#define MAYBE_SHARED(x) NAMEDCNT_GT_1(x)
#define NO_REFERENCES(x) NAMEDCNT_EQ_0(x)
#define MAYBE_REFERENCED(x) NAMEDCNT_GT_0(x)
#define NOT_SHARED(x) (! NAMEDCNT_GT_1(x))
#if MAX_NAMEDCNT!=2 && 1 /* Change 1 to 0 to disable "optimized" version */
#define SET_NAMEDCNT_MAX(x) do { \
SEXPREC *_p_ = UPTR_FROM_SEXP(x); \
......@@ -710,6 +703,13 @@ extern void helpers_wait_until_not_in_use(SEXP);
} while (0)
#endif
/* Macros for compatibility with later R Core versions. */
#define MAYBE_SHARED(x) NAMEDCNT_GT_1(x)
#define NO_REFERENCES(x) NAMEDCNT_EQ_0(x)
#define MAYBE_REFERENCED(x) NAMEDCNT_GT_0(x)
#define NOT_SHARED(x) (! NAMEDCNT_GT_1(x))
#define MARK_NOT_MUTABLE(x) SET_NAMEDCNT_MAX(x)
......
......@@ -1569,13 +1569,17 @@ static SEXP do_set (SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
Avoid accessing NAMEDCNT in a way that will cause unnecessary
waits for task completion.
Note that the check below catches items on the scalar stack. */
Note that the check below catches items on the scalar stack.
The copy is done with memcpy of 8 bytes, which is the minimum
space allocated for data (required by alignment), which will
not copy all of a complex item (hence CPLXSXP not handled here). */
int rhs_type_etc = TYPE_ETC(rhs); /* type + vec + attr + b.c. */
if (NAMEDCNT_GT_0(rhs)
&& (rhs_type_etc&~TYPE_ET_CETERA_TYPE)==0 /* scalar, no attr, n.b.c. */
&& ((NONPOINTER_VECTOR_TYPES >> rhs_type_etc) & 1)) {
&& (((NONPOINTER_VECTOR_TYPES & ~(1<<CPLXSXP)) >> rhs_type_etc) & 1)) {
if (v == R_UnboundValue)
v = findVarInFrame3_nolast (rho, lhs, 7);
if (TYPE_ETC(v) == rhs_type_etc /* won't be if R_UnboundValue */
......@@ -1584,20 +1588,7 @@ static SEXP do_set (SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
SET_NAMEDCNT_NOT_0(v);
(void) POP_IF_TOP_OF_STACK(rhs);
WAIT_UNTIL_NOT_IN_USE(v); /* won't be being computed */
switch (rhs_type_etc) {
case REALSXP:
*REAL(v) = *REAL(rhs);
break;
case CPLXSXP:
*COMPLEX(v) = *COMPLEX(rhs);
break;
case RAWSXP:
*RAW(v) = *RAW(rhs);
break;
default: /* INTSXP or LGLSXP */
*INTEGER(v) = *INTEGER(rhs);
break;
}
memcpy(REAL(v),REAL(rhs),sizeof(double)); /* others no bigger */
rhs = v; /* for return value */
goto done;
}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment