| /* |
| * R : A Computer Language for Statistical Data Analysis |
| * Copyright (C) 1998--2019 The R Core Team. |
| * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka |
| * |
| * 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/ |
| */ |
| |
| /* |
| * This code implements a non-moving generational collector |
| * with two or three generations. |
| * |
| * Memory allocated by R_alloc is maintained in a stack. Code |
| * that R_allocs memory must use vmaxget and vmaxset to obtain |
| * and reset the stack pointer. |
| */ |
| |
| #define USE_RINTERNALS |
| #define COMPILING_MEMORY_C |
| |
| #ifdef HAVE_CONFIG_H |
| #include <config.h> |
| #endif |
| |
| #include <stdarg.h> |
| |
| #include <R_ext/RS.h> /* for S4 allocation */ |
| #include <R_ext/Print.h> |
| |
| /* Declarations for Valgrind. |
| |
| These are controlled by the |
| --with-valgrind-instrumentation= |
| option to configure, which sets VALGRIND_LEVEL to the |
| supplied value (default 0) and defines NVALGRIND if |
| the value is 0. |
| |
| level 0 is no additional instrumentation |
| level 1 marks uninitialized numeric, logical, integer, raw, |
| complex vectors and R_alloc memory |
| level 2 marks the data section of vector nodes as inaccessible |
| when they are freed. |
| |
| level 3 was withdrawn in R 3.2.0. |
| |
| It may be necessary to define NVALGRIND for a non-gcc |
| compiler on a supported architecture if it has different |
| syntax for inline assembly language from gcc. |
| |
| For Win32, Valgrind is useful only if running under Wine. |
| */ |
| #ifdef Win32 |
| # ifndef USE_VALGRIND_FOR_WINE |
| # define NVALGRIND 1 |
| #endif |
| #endif |
| |
| |
| #ifndef VALGRIND_LEVEL |
| # define VALGRIND_LEVEL 0 |
| #endif |
| |
| #ifndef NVALGRIND |
| # ifdef HAVE_VALGRIND_MEMCHECK_H |
| # include "valgrind/memcheck.h" |
| # else |
| // internal version of headers |
| # include "vg/memcheck.h" |
| # endif |
| #endif |
| |
| |
| #define R_USE_SIGNALS 1 |
| #include <Defn.h> |
| #include <Internal.h> |
| #include <R_ext/GraphicsEngine.h> /* GEDevDesc, GEgetDevice */ |
| #include <R_ext/Rdynload.h> |
| #include <R_ext/Rallocators.h> /* for R_allocator_t structure */ |
| #include <Rmath.h> // R_pow_di |
| #include <Print.h> // R_print |
| |
| #if defined(Win32) |
| extern void *Rm_malloc(size_t n); |
| extern void *Rm_calloc(size_t n_elements, size_t element_size); |
| extern void Rm_free(void * p); |
| extern void *Rm_realloc(void * p, size_t n); |
| #define calloc Rm_calloc |
| #define malloc Rm_malloc |
| #define realloc Rm_realloc |
| #define free Rm_free |
| #endif |
| |
| /* malloc uses size_t. We are assuming here that size_t is at least |
| as large as unsigned long. Changed from int at 1.6.0 to (i) allow |
| 2-4Gb objects on 32-bit system and (ii) objects limited only by |
| length on a 64-bit system. |
| */ |
| |
| static int gc_reporting = 0; |
| static int gc_count = 0; |
| |
| /* These are used in profiling to separate out time in GC */ |
| int R_gc_running() { return R_in_gc; } |
| |
| #ifdef TESTING_WRITE_BARRIER |
| # define PROTECTCHECK |
| #endif |
| |
| #ifdef PROTECTCHECK |
| /* This is used to help detect unprotected SEXP values. It is most |
| useful if the strict barrier is enabled as well. The strategy is: |
| |
| All GCs are full GCs |
| |
| New nodes are marked as NEWSXP |
| |
| After a GC all free nodes that are not of type NEWSXP are |
| marked as type FREESXP |
| |
| Most calls to accessor functions check their SEXP inputs and |
| SEXP outputs with CHK() to see if a reachable node is a |
| FREESXP and signal an error if a FREESXP is found. |
| |
| Combined with GC torture this can help locate where an unprotected |
| SEXP is being used. |
| |
| This approach will miss cases where an unprotected node has been |
| re-allocated. For these cases it is possible to set |
| gc_inhibit_release to TRUE. FREESXP nodes will not be reallocated, |
| or large ones released, until gc_inhibit_release is set to FALSE |
| again. This will of course result in memory growth and should be |
| used with care and typically in combination with OS mechanisms to |
| limit process memory usage. LT */ |
| |
| /* Before a node is marked as a FREESXP by the collector the previous |
| type is recorded. For now using the LEVELS field seems |
| reasonable. */ |
| #define OLDTYPE(s) LEVELS(s) |
| #define SETOLDTYPE(s, t) SETLEVELS(s, t) |
| |
| static R_INLINE SEXP CHK(SEXP x) |
| { |
| /* **** NULL check because of R_CurrentExpr */ |
| if (x != NULL && TYPEOF(x) == FREESXP) |
| error("unprotected object (%p) encountered (was %s)", |
| x, sexptype2char(OLDTYPE(x))); |
| return x; |
| } |
| #else |
| #define CHK(x) x |
| #endif |
| |
| /* The following three variables definitions are used to record the |
| address and type of the first bad type seen during a collection, |
| and for FREESXP nodes they record the old type as well. */ |
| static SEXPTYPE bad_sexp_type_seen = 0; |
| static SEXP bad_sexp_type_sexp = NULL; |
| #ifdef PROTECTCHECK |
| static SEXPTYPE bad_sexp_type_old_type = 0; |
| #endif |
| static int bad_sexp_type_line = 0; |
| |
| static R_INLINE void register_bad_sexp_type(SEXP s, int line) |
| { |
| if (bad_sexp_type_seen == 0) { |
| bad_sexp_type_seen = TYPEOF(s); |
| bad_sexp_type_sexp = s; |
| bad_sexp_type_line = line; |
| #ifdef PROTECTCHECK |
| if (TYPEOF(s) == FREESXP) |
| bad_sexp_type_old_type = OLDTYPE(s); |
| #endif |
| } |
| } |
| |
| /* also called from typename() in inspect.c */ |
| attribute_hidden |
| const char *sexptype2char(SEXPTYPE type) { |
| switch (type) { |
| case NILSXP: return "NILSXP"; |
| case SYMSXP: return "SYMSXP"; |
| case LISTSXP: return "LISTSXP"; |
| case CLOSXP: return "CLOSXP"; |
| case ENVSXP: return "ENVSXP"; |
| case PROMSXP: return "PROMSXP"; |
| case LANGSXP: return "LANGSXP"; |
| case SPECIALSXP: return "SPECIALSXP"; |
| case BUILTINSXP: return "BUILTINSXP"; |
| case CHARSXP: return "CHARSXP"; |
| case LGLSXP: return "LGLSXP"; |
| case INTSXP: return "INTSXP"; |
| case REALSXP: return "REALSXP"; |
| case CPLXSXP: return "CPLXSXP"; |
| case STRSXP: return "STRSXP"; |
| case DOTSXP: return "DOTSXP"; |
| case ANYSXP: return "ANYSXP"; |
| case VECSXP: return "VECSXP"; |
| case EXPRSXP: return "EXPRSXP"; |
| case BCODESXP: return "BCODESXP"; |
| case EXTPTRSXP: return "EXTPTRSXP"; |
| case WEAKREFSXP: return "WEAKREFSXP"; |
| case S4SXP: return "S4SXP"; |
| case RAWSXP: return "RAWSXP"; |
| case NEWSXP: return "NEWSXP"; /* should never happen */ |
| case FREESXP: return "FREESXP"; |
| default: return "<unknown>"; |
| } |
| } |
| |
| #define GC_TORTURE |
| |
| static int gc_pending = 0; |
| #ifdef GC_TORTURE |
| /* **** if the user specified a wait before starting to force |
| **** collections it might make sense to also wait before starting |
| **** to inhibit releases */ |
| static int gc_force_wait = 0; |
| static int gc_force_gap = 0; |
| static Rboolean gc_inhibit_release = FALSE; |
| #define FORCE_GC (gc_pending || (gc_force_wait > 0 ? (--gc_force_wait > 0 ? 0 : (gc_force_wait = gc_force_gap, 1)) : 0)) |
| #else |
| # define FORCE_GC gc_pending |
| #endif |
| |
| #ifdef R_MEMORY_PROFILING |
| static void R_ReportAllocation(R_size_t); |
| static void R_ReportNewPage(); |
| #endif |
| |
| #define GC_PROT(X) do { \ |
| int __wait__ = gc_force_wait; \ |
| int __gap__ = gc_force_gap; \ |
| Rboolean __release__ = gc_inhibit_release; \ |
| X; \ |
| gc_force_wait = __wait__; \ |
| gc_force_gap = __gap__; \ |
| gc_inhibit_release = __release__; \ |
| } while(0) |
| |
| static void R_gc_internal(R_size_t size_needed); |
| static void R_gc_no_finalizers(R_size_t size_needed); |
| static void R_gc_lite(); |
| static void mem_err_heap(R_size_t size); |
| static void mem_err_malloc(R_size_t size); |
| |
| static SEXPREC UnmarkedNodeTemplate; |
| #define NODE_IS_MARKED(s) (MARK(s)==1) |
| #define MARK_NODE(s) (MARK(s)=1) |
| #define UNMARK_NODE(s) (MARK(s)=0) |
| |
| |
| /* Tuning Constants. Most of these could be made settable from R, |
| within some reasonable constraints at least. Since there are quite |
| a lot of constants it would probably make sense to put together |
| several "packages" representing different space/speed tradeoffs |
| (e.g. very aggressive freeing and small increments to conserve |
| memory; much less frequent releasing and larger increments to |
| increase speed). */ |
| |
| /* There are three levels of collections. Level 0 collects only the |
| youngest generation, level 1 collects the two youngest generations, |
| and level 2 collects all generations. Higher level collections |
| occur at least after specified numbers of lower level ones. After |
| LEVEL_0_FREQ level zero collections a level 1 collection is done; |
| after every LEVEL_1_FREQ level 1 collections a level 2 collection |
| occurs. Thus, roughly, every LEVEL_0_FREQ-th collection is a level |
| 1 collection and every (LEVEL_0_FREQ * LEVEL_1_FREQ)-th collection |
| is a level 2 collection. */ |
| #define LEVEL_0_FREQ 20 |
| #define LEVEL_1_FREQ 5 |
| static int collect_counts_max[] = { LEVEL_0_FREQ, LEVEL_1_FREQ }; |
| |
| /* When a level N collection fails to produce at least MinFreeFrac * |
| R_NSize free nodes and MinFreeFrac * R_VSize free vector space, the |
| next collection will be a level N + 1 collection. |
| |
| This constant is also used in heap size adjustment as a minimal |
| fraction of the minimal heap size levels that should be available |
| for allocation. */ |
| static double R_MinFreeFrac = 0.2; |
| |
| /* When pages are released, a number of free nodes equal to |
| R_MaxKeepFrac times the number of allocated nodes for each class is |
| retained. Pages not needed to meet this requirement are released. |
| An attempt to release pages is made every R_PageReleaseFreq level 1 |
| or level 2 collections. */ |
| static double R_MaxKeepFrac = 0.5; |
| static int R_PageReleaseFreq = 1; |
| |
| /* The heap size constants R_NSize and R_VSize are used for triggering |
| collections. The initial values set by defaults or command line |
| arguments are used as minimal values. After full collections these |
| levels are adjusted up or down, though not below the minimal values |
| or above the maximum values, towards maintain heap occupancy within |
| a specified range. When the number of nodes in use reaches |
| R_NGrowFrac * R_NSize, the value of R_NSize is incremented by |
| R_NGrowIncrMin + R_NGrowIncrFrac * R_NSize. When the number of |
| nodes in use falls below R_NShrinkFrac, R_NSize is decremented by |
| R_NShrinkIncrMin + R_NShrinkFrac * R_NSize. Analogous adjustments |
| are made to R_VSize. |
| |
| This mechanism for adjusting the heap size constants is very |
| primitive but hopefully adequate for now. Some modeling and |
| experimentation would be useful. We want the heap sizes to get set |
| at levels adequate for the current computations. The present |
| mechanism uses only the size of the current live heap to provide |
| information about the current needs; since the current live heap |
| size can be very volatile, the adjustment mechanism only makes |
| gradual adjustments. A more sophisticated strategy would use more |
| of the live heap history. |
| |
| Some of the settings can now be adjusted by environment variables. |
| */ |
| static double R_NGrowFrac = 0.70; |
| static double R_NShrinkFrac = 0.30; |
| |
| static double R_VGrowFrac = 0.70; |
| static double R_VShrinkFrac = 0.30; |
| |
| #ifdef SMALL_MEMORY |
| /* On machines with only 32M of memory (or on a classic Mac OS port) |
| it might be a good idea to use settings like these that are more |
| aggressive at keeping memory usage down. */ |
| static double R_NGrowIncrFrac = 0.0, R_NShrinkIncrFrac = 0.2; |
| static int R_NGrowIncrMin = 50000, R_NShrinkIncrMin = 0; |
| static double R_VGrowIncrFrac = 0.0, R_VShrinkIncrFrac = 0.2; |
| static int R_VGrowIncrMin = 100000, R_VShrinkIncrMin = 0; |
| #else |
| static double R_NGrowIncrFrac = 0.2, R_NShrinkIncrFrac = 0.2; |
| static int R_NGrowIncrMin = 40000, R_NShrinkIncrMin = 0; |
| static double R_VGrowIncrFrac = 0.2, R_VShrinkIncrFrac = 0.2; |
| static int R_VGrowIncrMin = 80000, R_VShrinkIncrMin = 0; |
| #endif |
| |
| static void init_gc_grow_settings() |
| { |
| char *arg; |
| |
| arg = getenv("R_GC_MEM_GROW"); |
| if (arg != NULL) { |
| int which = (int) atof(arg); |
| switch (which) { |
| case 0: /* very conservative -- the SMALL_MEMORY settings */ |
| R_NGrowIncrFrac = 0.0; |
| R_VGrowIncrFrac = 0.0; |
| break; |
| case 1: /* default */ |
| break; |
| case 2: /* somewhat aggressive */ |
| R_NGrowIncrFrac = 0.3; |
| R_VGrowIncrFrac = 0.3; |
| break; |
| case 3: /* more aggressive */ |
| R_NGrowIncrFrac = 0.4; |
| R_VGrowIncrFrac = 0.4; |
| R_NGrowFrac = 0.5; |
| R_VGrowFrac = 0.5; |
| break; |
| } |
| } |
| arg = getenv("R_GC_GROWFRAC"); |
| if (arg != NULL) { |
| double frac = atof(arg); |
| if (0.35 <= frac && frac <= 0.75) { |
| R_NGrowFrac = frac; |
| R_VGrowFrac = frac; |
| } |
| } |
| arg = getenv("R_GC_GROWINCRFRAC"); |
| if (arg != NULL) { |
| double frac = atof(arg); |
| if (0.05 <= frac && frac <= 0.80) { |
| R_NGrowIncrFrac = frac; |
| R_VGrowIncrFrac = frac; |
| } |
| } |
| arg = getenv("R_GC_NGROWINCRFRAC"); |
| if (arg != NULL) { |
| double frac = atof(arg); |
| if (0.05 <= frac && frac <= 0.80) |
| R_NGrowIncrFrac = frac; |
| } |
| arg = getenv("R_GC_VGROWINCRFRAC"); |
| if (arg != NULL) { |
| double frac = atof(arg); |
| if (0.05 <= frac && frac <= 0.80) |
| R_VGrowIncrFrac = frac; |
| } |
| } |
| |
| /* Maximal Heap Limits. These variables contain upper limits on the |
| heap sizes. They could be made adjustable from the R level, |
| perhaps by a handler for a recoverable error. |
| |
| Access to these values is provided with reader and writer |
| functions; the writer function insures that the maximal values are |
| never set below the current ones. */ |
| static R_size_t R_MaxVSize = R_SIZE_T_MAX; |
| static R_size_t R_MaxNSize = R_SIZE_T_MAX; |
| static int vsfac = 1; /* current units for vsize: changes at initialization */ |
| |
| R_size_t attribute_hidden R_GetMaxVSize(void) |
| { |
| if (R_MaxVSize == R_SIZE_T_MAX) return R_SIZE_T_MAX; |
| return R_MaxVSize * vsfac; |
| } |
| |
| void attribute_hidden R_SetMaxVSize(R_size_t size) |
| { |
| if (size == R_SIZE_T_MAX) return; |
| if (size / vsfac >= R_VSize) R_MaxVSize = (size + 1) / vsfac; |
| } |
| |
| R_size_t attribute_hidden R_GetMaxNSize(void) |
| { |
| return R_MaxNSize; |
| } |
| |
| void attribute_hidden R_SetMaxNSize(R_size_t size) |
| { |
| if (size >= R_NSize) R_MaxNSize = size; |
| } |
| |
| void attribute_hidden R_SetPPSize(R_size_t size) |
| { |
| R_PPStackSize = (int) size; |
| } |
| |
| SEXP attribute_hidden do_maxVSize(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| const double MB = 1048576.0; |
| double newval = asReal(CAR(args)); |
| |
| if (newval > 0) { |
| if (newval == R_PosInf) |
| R_MaxVSize = R_SIZE_T_MAX; |
| else |
| R_SetMaxVSize((R_size_t) (newval * MB)); |
| } |
| |
| if (R_MaxVSize == R_SIZE_T_MAX) |
| return ScalarReal(R_PosInf); |
| else |
| return ScalarReal(R_GetMaxVSize() / MB); |
| } |
| |
| SEXP attribute_hidden do_maxNSize(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| double newval = asReal(CAR(args)); |
| |
| if (newval > 0) { |
| if (newval == R_PosInf) |
| R_MaxNSize = R_SIZE_T_MAX; |
| else |
| R_SetMaxNSize((R_size_t) newval); |
| } |
| |
| if (R_MaxNSize == R_SIZE_T_MAX) |
| return ScalarReal(R_PosInf); |
| else |
| return ScalarReal(R_GetMaxNSize()); |
| } |
| |
| |
| /* Miscellaneous Globals. */ |
| |
| static SEXP R_VStack = NULL; /* R_alloc stack pointer */ |
| static SEXP R_PreciousList = NULL; /* List of Persistent Objects */ |
| static R_size_t R_LargeVallocSize = 0; |
| static R_size_t R_SmallVallocSize = 0; |
| static R_size_t orig_R_NSize; |
| static R_size_t orig_R_VSize; |
| |
| static R_size_t R_N_maxused=0; |
| static R_size_t R_V_maxused=0; |
| |
| /* Node Classes. Non-vector nodes are of class zero. Small vector |
| nodes are in classes 1, ..., NUM_SMALL_NODE_CLASSES, and large |
| vector nodes are in class LARGE_NODE_CLASS. Vectors with |
| custom allocators are in CUSTOM_NODE_CLASS. For vector nodes the |
| node header is followed in memory by the vector data, offset from |
| the header by SEXPREC_ALIGN. */ |
| |
| #define NUM_NODE_CLASSES 8 |
| |
| /* sxpinfo allocates 3 bits for the node class, so at most 8 are allowed */ |
| #if NUM_NODE_CLASSES > 8 |
| # error NUM_NODE_CLASSES must be at most 8 |
| #endif |
| |
| #define LARGE_NODE_CLASS (NUM_NODE_CLASSES - 1) |
| #define CUSTOM_NODE_CLASS (NUM_NODE_CLASSES - 2) |
| #define NUM_SMALL_NODE_CLASSES (NUM_NODE_CLASSES - 2) |
| |
| /* the number of VECREC's in nodes of the small node classes */ |
| static int NodeClassSize[NUM_SMALL_NODE_CLASSES] = { 0, 1, 2, 4, 8, 16 }; |
| |
| #define NODE_CLASS(s) ((s)->sxpinfo.gccls) |
| #define SET_NODE_CLASS(s,v) (((s)->sxpinfo.gccls) = (v)) |
| |
| |
| /* Node Generations. */ |
| |
| #define NUM_OLD_GENERATIONS 2 |
| |
| /* sxpinfo allocates one bit for the old generation count, so only 1 |
| or 2 is allowed */ |
| #if NUM_OLD_GENERATIONS > 2 || NUM_OLD_GENERATIONS < 1 |
| # error number of old generations must be 1 or 2 |
| #endif |
| |
| #define NODE_GENERATION(s) ((s)->sxpinfo.gcgen) |
| #define SET_NODE_GENERATION(s,g) ((s)->sxpinfo.gcgen=(g)) |
| |
| #define NODE_GEN_IS_YOUNGER(s,g) \ |
| (! NODE_IS_MARKED(s) || NODE_GENERATION(s) < (g)) |
| #define NODE_IS_OLDER(x, y) \ |
| (NODE_IS_MARKED(x) && (y) && \ |
| (! NODE_IS_MARKED(y) || NODE_GENERATION(x) > NODE_GENERATION(y))) |
| |
| static int num_old_gens_to_collect = 0; |
| static int gen_gc_counts[NUM_OLD_GENERATIONS + 1]; |
| static int collect_counts[NUM_OLD_GENERATIONS]; |
| |
| |
| /* Node Pages. Non-vector nodes and small vector nodes are allocated |
| from fixed size pages. The pages for each node class are kept in a |
| linked list. */ |
| |
| typedef union PAGE_HEADER { |
| union PAGE_HEADER *next; |
| double align; |
| } PAGE_HEADER; |
| |
| #if ( SIZEOF_SIZE_T > 4 ) |
| # define BASE_PAGE_SIZE 8000 |
| #else |
| # define BASE_PAGE_SIZE 2000 |
| #endif |
| #define R_PAGE_SIZE \ |
| (((BASE_PAGE_SIZE - sizeof(PAGE_HEADER)) / sizeof(SEXPREC)) \ |
| * sizeof(SEXPREC) \ |
| + sizeof(PAGE_HEADER)) |
| #define NODE_SIZE(c) \ |
| ((c) == 0 ? sizeof(SEXPREC) : \ |
| sizeof(SEXPREC_ALIGN) + NodeClassSize[c] * sizeof(VECREC)) |
| |
| #define PAGE_DATA(p) ((void *) (p + 1)) |
| #define VHEAP_FREE() (R_VSize - R_LargeVallocSize - R_SmallVallocSize) |
| |
| |
| /* The Heap Structure. Nodes for each class/generation combination |
| are arranged in circular doubly-linked lists. The double linking |
| allows nodes to be removed in constant time; this is used by the |
| collector to move reachable nodes out of free space and into the |
| appropriate generation. The circularity eliminates the need for |
| end checks. In addition, each link is anchored at an artificial |
| node, the Peg SEXPREC's in the structure below, which simplifies |
| pointer maintenance. The circular doubly-linked arrangement is |
| taken from Baker's in-place incremental collector design; see |
| ftp://ftp.netcom.com/pub/hb/hbaker/NoMotionGC.html or the Jones and |
| Lins GC book. The linked lists are implemented by adding two |
| pointer fields to the SEXPREC structure, which increases its size |
| from 5 to 7 words. Other approaches are possible but don't seem |
| worth pursuing for R. |
| |
| There are two options for dealing with old-to-new pointers. The |
| first option is to make sure they never occur by transferring all |
| referenced younger objects to the generation of the referrer when a |
| reference to a newer object is assigned to an older one. This is |
| enabled by defining EXPEL_OLD_TO_NEW. The second alternative is to |
| keep track of all nodes that may contain references to newer nodes |
| and to "age" the nodes they refer to at the beginning of each |
| collection. This is the default. The first option is simpler in |
| some ways, but will create more floating garbage and add a bit to |
| the execution time, though the difference is probably marginal on |
| both counts.*/ |
| /*#define EXPEL_OLD_TO_NEW*/ |
| static struct { |
| SEXP Old[NUM_OLD_GENERATIONS], New, Free; |
| SEXPREC OldPeg[NUM_OLD_GENERATIONS], NewPeg; |
| #ifndef EXPEL_OLD_TO_NEW |
| SEXP OldToNew[NUM_OLD_GENERATIONS]; |
| SEXPREC OldToNewPeg[NUM_OLD_GENERATIONS]; |
| #endif |
| int OldCount[NUM_OLD_GENERATIONS], AllocCount, PageCount; |
| PAGE_HEADER *pages; |
| } R_GenHeap[NUM_NODE_CLASSES]; |
| |
| static R_size_t R_NodesInUse = 0; |
| |
| #define NEXT_NODE(s) (s)->gengc_next_node |
| #define PREV_NODE(s) (s)->gengc_prev_node |
| #define SET_NEXT_NODE(s,t) (NEXT_NODE(s) = (t)) |
| #define SET_PREV_NODE(s,t) (PREV_NODE(s) = (t)) |
| |
| |
| /* Node List Manipulation */ |
| |
| /* unsnap node s from its list */ |
| #define UNSNAP_NODE(s) do { \ |
| SEXP un__n__ = (s); \ |
| SEXP next = NEXT_NODE(un__n__); \ |
| SEXP prev = PREV_NODE(un__n__); \ |
| SET_NEXT_NODE(prev, next); \ |
| SET_PREV_NODE(next, prev); \ |
| } while(0) |
| |
| /* snap in node s before node t */ |
| #define SNAP_NODE(s,t) do { \ |
| SEXP sn__n__ = (s); \ |
| SEXP next = (t); \ |
| SEXP prev = PREV_NODE(next); \ |
| SET_NEXT_NODE(sn__n__, next); \ |
| SET_PREV_NODE(next, sn__n__); \ |
| SET_NEXT_NODE(prev, sn__n__); \ |
| SET_PREV_NODE(sn__n__, prev); \ |
| } while (0) |
| |
| /* move all nodes on from_peg to to_peg */ |
| #define BULK_MOVE(from_peg,to_peg) do { \ |
| SEXP __from__ = (from_peg); \ |
| SEXP __to__ = (to_peg); \ |
| SEXP first_old = NEXT_NODE(__from__); \ |
| SEXP last_old = PREV_NODE(__from__); \ |
| SEXP first_new = NEXT_NODE(__to__); \ |
| SET_PREV_NODE(first_old, __to__); \ |
| SET_NEXT_NODE(__to__, first_old); \ |
| SET_PREV_NODE(first_new, last_old); \ |
| SET_NEXT_NODE(last_old, first_new); \ |
| SET_NEXT_NODE(__from__, __from__); \ |
| SET_PREV_NODE(__from__, __from__); \ |
| } while (0); |
| |
| |
| /* Processing Node Children */ |
| |
| /* This macro calls dc__action__ for each child of __n__, passing |
| dc__extra__ as a second argument for each call. */ |
| /* When the CHARSXP hash chains are maintained through the ATTRIB |
| field it is important that we NOT trace those fields otherwise too |
| many CHARSXPs will be kept alive artificially. As a safety we don't |
| ignore all non-NULL ATTRIB values for CHARSXPs but only those that |
| are themselves CHARSXPs, which is what they will be if they are |
| part of a hash chain. Theoretically, for CHARSXPs the ATTRIB field |
| should always be either R_NilValue or a CHARSXP. */ |
| #ifdef PROTECTCHECK |
| # define HAS_GENUINE_ATTRIB(x) \ |
| (TYPEOF(x) != FREESXP && ATTRIB(x) != R_NilValue && \ |
| (TYPEOF(x) != CHARSXP || TYPEOF(ATTRIB(x)) != CHARSXP)) |
| #else |
| # define HAS_GENUINE_ATTRIB(x) \ |
| (ATTRIB(x) != R_NilValue && \ |
| (TYPEOF(x) != CHARSXP || TYPEOF(ATTRIB(x)) != CHARSXP)) |
| #endif |
| |
| #ifdef PROTECTCHECK |
| #define FREE_FORWARD_CASE case FREESXP: if (gc_inhibit_release) break; |
| #else |
| #define FREE_FORWARD_CASE |
| #endif |
| /*** assume for now all ALTREP nodes are based on CONS nodes */ |
| #define DO_CHILDREN(__n__,dc__action__,dc__extra__) do { \ |
| if (HAS_GENUINE_ATTRIB(__n__)) \ |
| dc__action__(ATTRIB(__n__), dc__extra__); \ |
| if (ALTREP(__n__)) { \ |
| dc__action__(TAG(__n__), dc__extra__); \ |
| dc__action__(CAR(__n__), dc__extra__); \ |
| dc__action__(CDR(__n__), dc__extra__); \ |
| } \ |
| else \ |
| switch (TYPEOF(__n__)) { \ |
| case NILSXP: \ |
| case BUILTINSXP: \ |
| case SPECIALSXP: \ |
| case CHARSXP: \ |
| case LGLSXP: \ |
| case INTSXP: \ |
| case REALSXP: \ |
| case CPLXSXP: \ |
| case WEAKREFSXP: \ |
| case RAWSXP: \ |
| case S4SXP: \ |
| break; \ |
| case STRSXP: \ |
| case EXPRSXP: \ |
| case VECSXP: \ |
| { \ |
| R_xlen_t i; \ |
| for (i = 0; i < XLENGTH(__n__); i++) \ |
| dc__action__(VECTOR_ELT(__n__, i), dc__extra__); \ |
| } \ |
| break; \ |
| case ENVSXP: \ |
| dc__action__(FRAME(__n__), dc__extra__); \ |
| dc__action__(ENCLOS(__n__), dc__extra__); \ |
| dc__action__(HASHTAB(__n__), dc__extra__); \ |
| break; \ |
| case CLOSXP: \ |
| case PROMSXP: \ |
| case LISTSXP: \ |
| case LANGSXP: \ |
| case DOTSXP: \ |
| case SYMSXP: \ |
| case BCODESXP: \ |
| dc__action__(TAG(__n__), dc__extra__); \ |
| dc__action__(CAR(__n__), dc__extra__); \ |
| dc__action__(CDR(__n__), dc__extra__); \ |
| break; \ |
| case EXTPTRSXP: \ |
| dc__action__(EXTPTR_PROT(__n__), dc__extra__); \ |
| dc__action__(EXTPTR_TAG(__n__), dc__extra__); \ |
| break; \ |
| FREE_FORWARD_CASE \ |
| default: \ |
| register_bad_sexp_type(__n__, __LINE__); \ |
| } \ |
| } while(0) |
| |
| |
| /* Forwarding Nodes. These macros mark nodes or children of nodes and |
| place them on the forwarding list. The forwarding list is assumed |
| to be in a local variable of the caller named named |
| forwarded_nodes. */ |
| |
| #define FORWARD_NODE(s) do { \ |
| SEXP fn__n__ = (s); \ |
| if (fn__n__ && ! NODE_IS_MARKED(fn__n__)) { \ |
| CHECK_FOR_FREE_NODE(fn__n__) \ |
| MARK_NODE(fn__n__); \ |
| UNSNAP_NODE(fn__n__); \ |
| SET_NEXT_NODE(fn__n__, forwarded_nodes); \ |
| forwarded_nodes = fn__n__; \ |
| } \ |
| } while (0) |
| |
| #define FC_FORWARD_NODE(__n__,__dummy__) FORWARD_NODE(__n__) |
| #define FORWARD_CHILDREN(__n__) DO_CHILDREN(__n__,FC_FORWARD_NODE, 0) |
| |
| /* This macro should help localize where a FREESXP node is encountered |
| in the GC */ |
| #ifdef PROTECTCHECK |
| #define CHECK_FOR_FREE_NODE(s) { \ |
| SEXP cf__n__ = (s); \ |
| if (TYPEOF(cf__n__) == FREESXP && ! gc_inhibit_release) \ |
| register_bad_sexp_type(cf__n__, __LINE__); \ |
| } |
| #else |
| #define CHECK_FOR_FREE_NODE(s) |
| #endif |
| |
| |
| /* Node Allocation. */ |
| |
| #define CLASS_GET_FREE_NODE(c,s) do { \ |
| SEXP __n__ = R_GenHeap[c].Free; \ |
| if (__n__ == R_GenHeap[c].New) { \ |
| GetNewPage(c); \ |
| __n__ = R_GenHeap[c].Free; \ |
| } \ |
| R_GenHeap[c].Free = NEXT_NODE(__n__); \ |
| R_NodesInUse++; \ |
| (s) = __n__; \ |
| } while (0) |
| |
| #define NO_FREE_NODES() (R_NodesInUse >= R_NSize) |
| #define GET_FREE_NODE(s) CLASS_GET_FREE_NODE(0,s) |
| |
| /* versions that assume nodes are avaialble without adding a new page */ |
| #define CLASS_QUICK_GET_FREE_NODE(c,s) do { \ |
| SEXP __n__ = R_GenHeap[c].Free; \ |
| if (__n__ == R_GenHeap[c].New) \ |
| error("need new page - should not happen"); \ |
| R_GenHeap[c].Free = NEXT_NODE(__n__); \ |
| R_NodesInUse++; \ |
| (s) = __n__; \ |
| } while (0) |
| |
| #define QUICK_GET_FREE_NODE(s) CLASS_QUICK_GET_FREE_NODE(0,s) |
| |
| /* QUICK versions can be used if (CLASS_)NEED_NEW_PAGE returns FALSE */ |
| #define CLASS_NEED_NEW_PAGE(c) (R_GenHeap[c].Free == R_GenHeap[c].New) |
| #define NEED_NEW_PAGE() CLASS_NEED_NEW_PAGE(0) |
| |
| |
| /* Debugging Routines. */ |
| |
| #ifdef DEBUG_GC |
| static void CheckNodeGeneration(SEXP x, int g) |
| { |
| if (x && NODE_GENERATION(x) < g) { |
| REprintf("untraced old-to-new reference\n"); |
| } |
| } |
| |
| static void DEBUG_CHECK_NODE_COUNTS(char *where) |
| { |
| int i, OldCount, NewCount, OldToNewCount, gen; |
| SEXP s; |
| |
| REprintf("Node counts %s:\n", where); |
| for (i = 0; i < NUM_NODE_CLASSES; i++) { |
| for (s = NEXT_NODE(R_GenHeap[i].New), NewCount = 0; |
| s != R_GenHeap[i].New; |
| s = NEXT_NODE(s)) { |
| NewCount++; |
| if (i != NODE_CLASS(s)) |
| REprintf("Inconsistent class assignment for node!\n"); |
| } |
| for (gen = 0, OldCount = 0, OldToNewCount = 0; |
| gen < NUM_OLD_GENERATIONS; |
| gen++) { |
| for (s = NEXT_NODE(R_GenHeap[i].Old[gen]); |
| s != R_GenHeap[i].Old[gen]; |
| s = NEXT_NODE(s)) { |
| OldCount++; |
| if (i != NODE_CLASS(s)) |
| REprintf("Inconsistent class assignment for node!\n"); |
| if (gen != NODE_GENERATION(s)) |
| REprintf("Inconsistent node generation\n"); |
| DO_CHILDREN(s, CheckNodeGeneration, gen); |
| } |
| for (s = NEXT_NODE(R_GenHeap[i].OldToNew[gen]); |
| s != R_GenHeap[i].OldToNew[gen]; |
| s = NEXT_NODE(s)) { |
| OldToNewCount++; |
| if (i != NODE_CLASS(s)) |
| REprintf("Inconsistent class assignment for node!\n"); |
| if (gen != NODE_GENERATION(s)) |
| REprintf("Inconsistent node generation\n"); |
| } |
| } |
| REprintf("Class: %d, New = %d, Old = %d, OldToNew = %d, Total = %d\n", |
| i, |
| NewCount, OldCount, OldToNewCount, |
| NewCount + OldCount + OldToNewCount); |
| } |
| } |
| |
| static void DEBUG_GC_SUMMARY(int full_gc) |
| { |
| int i, gen, OldCount; |
| REprintf("\n%s, VSize = %lu", full_gc ? "Full" : "Minor", |
| R_SmallVallocSize + R_LargeVallocSize); |
| for (i = 1; i < NUM_NODE_CLASSES; i++) { |
| for (gen = 0, OldCount = 0; gen < NUM_OLD_GENERATIONS; gen++) |
| OldCount += R_GenHeap[i].OldCount[gen]; |
| REprintf(", class %d: %d", i, OldCount); |
| } |
| } |
| #else |
| #define DEBUG_CHECK_NODE_COUNTS(s) |
| #define DEBUG_GC_SUMMARY(x) |
| #endif /* DEBUG_GC */ |
| |
| #ifdef DEBUG_ADJUST_HEAP |
| static void DEBUG_ADJUST_HEAP_PRINT(double node_occup, double vect_occup) |
| { |
| int i; |
| R_size_t alloc; |
| REprintf("Node occupancy: %.0f%%\nVector occupancy: %.0f%%\n", |
| 100.0 * node_occup, 100.0 * vect_occup); |
| alloc = R_LargeVallocSize + |
| sizeof(SEXPREC_ALIGN) * R_GenHeap[LARGE_NODE_CLASS].AllocCount; |
| for (i = 0; i < NUM_SMALL_NODE_CLASSES; i++) |
| alloc += R_PAGE_SIZE * R_GenHeap[i].PageCount; |
| REprintf("Total allocation: %lu\n", alloc); |
| REprintf("Ncells %lu\nVcells %lu\n", R_NSize, R_VSize); |
| } |
| #else |
| #define DEBUG_ADJUST_HEAP_PRINT(node_occup, vect_occup) |
| #endif /* DEBUG_ADJUST_HEAP */ |
| |
| #ifdef DEBUG_RELEASE_MEM |
| static void DEBUG_RELEASE_PRINT(int rel_pages, int maxrel_pages, int i) |
| { |
| if (maxrel_pages > 0) { |
| int gen, n; |
| REprintf("Class: %d, pages = %d, maxrel = %d, released = %d\n", i, |
| R_GenHeap[i].PageCount, maxrel_pages, rel_pages); |
| for (gen = 0, n = 0; gen < NUM_OLD_GENERATIONS; gen++) |
| n += R_GenHeap[i].OldCount[gen]; |
| REprintf("Allocated = %d, in use = %d\n", R_GenHeap[i].AllocCount, n); |
| } |
| } |
| #else |
| #define DEBUG_RELEASE_PRINT(rel_pages, maxrel_pages, i) |
| #endif /* DEBUG_RELEASE_MEM */ |
| |
| #ifdef COMPUTE_REFCNT_VALUES |
| #define INIT_REFCNT(x) do { \ |
| SEXP __x__ = (x); \ |
| SET_REFCNT(__x__, 0); \ |
| SET_TRACKREFS(__x__, TRUE); \ |
| } while (0) |
| #else |
| #define INIT_REFCNT(x) do {} while (0) |
| #endif |
| |
| /* Page Allocation and Release. */ |
| |
| static void GetNewPage(int node_class) |
| { |
| SEXP s, base; |
| char *data; |
| PAGE_HEADER *page; |
| int node_size, page_count, i; // FIXME: longer type? |
| |
| node_size = NODE_SIZE(node_class); |
| page_count = (R_PAGE_SIZE - sizeof(PAGE_HEADER)) / node_size; |
| |
| page = malloc(R_PAGE_SIZE); |
| if (page == NULL) { |
| R_gc_no_finalizers(0); |
| page = malloc(R_PAGE_SIZE); |
| if (page == NULL) |
| mem_err_malloc((R_size_t) R_PAGE_SIZE); |
| } |
| #ifdef R_MEMORY_PROFILING |
| R_ReportNewPage(); |
| #endif |
| page->next = R_GenHeap[node_class].pages; |
| R_GenHeap[node_class].pages = page; |
| R_GenHeap[node_class].PageCount++; |
| |
| data = PAGE_DATA(page); |
| base = R_GenHeap[node_class].New; |
| for (i = 0; i < page_count; i++, data += node_size) { |
| s = (SEXP) data; |
| R_GenHeap[node_class].AllocCount++; |
| SNAP_NODE(s, base); |
| #if VALGRIND_LEVEL > 1 |
| if (NodeClassSize[node_class] > 0) |
| VALGRIND_MAKE_MEM_NOACCESS(STDVEC_DATAPTR(s), NodeClassSize[node_class]*sizeof(VECREC)); |
| #endif |
| s->sxpinfo = UnmarkedNodeTemplate.sxpinfo; |
| INIT_REFCNT(s); |
| SET_NODE_CLASS(s, node_class); |
| #ifdef PROTECTCHECK |
| SET_TYPEOF(s, NEWSXP); |
| #endif |
| base = s; |
| R_GenHeap[node_class].Free = s; |
| } |
| } |
| |
| static void ReleasePage(PAGE_HEADER *page, int node_class) |
| { |
| SEXP s; |
| char *data; |
| int node_size, page_count, i; |
| |
| node_size = NODE_SIZE(node_class); |
| page_count = (R_PAGE_SIZE - sizeof(PAGE_HEADER)) / node_size; |
| data = PAGE_DATA(page); |
| |
| for (i = 0; i < page_count; i++, data += node_size) { |
| s = (SEXP) data; |
| UNSNAP_NODE(s); |
| R_GenHeap[node_class].AllocCount--; |
| } |
| R_GenHeap[node_class].PageCount--; |
| free(page); |
| } |
| |
| static void TryToReleasePages(void) |
| { |
| SEXP s; |
| int i; |
| static int release_count = 0; |
| |
| if (release_count == 0) { |
| release_count = R_PageReleaseFreq; |
| for (i = 0; i < NUM_SMALL_NODE_CLASSES; i++) { |
| int pages_free = 0; |
| PAGE_HEADER *page, *last, *next; |
| int node_size = NODE_SIZE(i); |
| int page_count = (R_PAGE_SIZE - sizeof(PAGE_HEADER)) / node_size; |
| int maxrel, maxrel_pages, rel_pages, gen; |
| |
| maxrel = R_GenHeap[i].AllocCount; |
| for (gen = 0; gen < NUM_OLD_GENERATIONS; gen++) |
| maxrel -= (int)((1.0 + R_MaxKeepFrac) * |
| R_GenHeap[i].OldCount[gen]); |
| maxrel_pages = maxrel > 0 ? maxrel / page_count : 0; |
| |
| /* all nodes in New space should be both free and unmarked */ |
| for (page = R_GenHeap[i].pages, rel_pages = 0, last = NULL; |
| rel_pages < maxrel_pages && page != NULL;) { |
| int j, in_use; |
| char *data = PAGE_DATA(page); |
| |
| next = page->next; |
| for (in_use = 0, j = 0; j < page_count; |
| j++, data += node_size) { |
| s = (SEXP) data; |
| if (NODE_IS_MARKED(s)) { |
| in_use = 1; |
| break; |
| } |
| } |
| if (! in_use) { |
| ReleasePage(page, i); |
| if (last == NULL) |
| R_GenHeap[i].pages = next; |
| else |
| last->next = next; |
| pages_free++; |
| rel_pages++; |
| } |
| else last = page; |
| page = next; |
| } |
| DEBUG_RELEASE_PRINT(rel_pages, maxrel_pages, i); |
| R_GenHeap[i].Free = NEXT_NODE(R_GenHeap[i].New); |
| } |
| } |
| else release_count--; |
| } |
| |
| /* compute size in VEC units so result will fit in LENGTH field for FREESXPs */ |
| static R_INLINE R_size_t getVecSizeInVEC(SEXP s) |
| { |
| if (IS_GROWABLE(s)) |
| SET_STDVEC_LENGTH(s, XTRUELENGTH(s)); |
| |
| R_size_t size; |
| switch (TYPEOF(s)) { /* get size in bytes */ |
| case CHARSXP: |
| size = XLENGTH(s) + 1; |
| break; |
| case RAWSXP: |
| size = XLENGTH(s); |
| break; |
| case LGLSXP: |
| case INTSXP: |
| size = XLENGTH(s) * sizeof(int); |
| break; |
| case REALSXP: |
| size = XLENGTH(s) * sizeof(double); |
| break; |
| case CPLXSXP: |
| size = XLENGTH(s) * sizeof(Rcomplex); |
| break; |
| case STRSXP: |
| case EXPRSXP: |
| case VECSXP: |
| size = XLENGTH(s) * sizeof(SEXP); |
| break; |
| default: |
| register_bad_sexp_type(s, __LINE__); |
| size = 0; |
| } |
| return BYTE2VEC(size); |
| } |
| |
| static void custom_node_free(void *ptr); |
| |
| static void ReleaseLargeFreeVectors() |
| { |
| for (int node_class = CUSTOM_NODE_CLASS; node_class <= LARGE_NODE_CLASS; node_class++) { |
| SEXP s = NEXT_NODE(R_GenHeap[node_class].New); |
| while (s != R_GenHeap[node_class].New) { |
| SEXP next = NEXT_NODE(s); |
| if (CHAR(s) != NULL) { |
| R_size_t size; |
| #ifdef PROTECTCHECK |
| if (TYPEOF(s) == FREESXP) |
| size = STDVEC_LENGTH(s); |
| else |
| /* should not get here -- arrange for a warning/error? */ |
| size = getVecSizeInVEC(s); |
| #else |
| size = getVecSizeInVEC(s); |
| #endif |
| UNSNAP_NODE(s); |
| R_GenHeap[node_class].AllocCount--; |
| if (node_class == LARGE_NODE_CLASS) { |
| R_LargeVallocSize -= size; |
| free(s); |
| } else { |
| custom_node_free(s); |
| } |
| } |
| s = next; |
| } |
| } |
| } |
| |
| /* Heap Size Adjustment. */ |
| |
| static void AdjustHeapSize(R_size_t size_needed) |
| { |
| R_size_t R_MinNFree = (R_size_t)(orig_R_NSize * R_MinFreeFrac); |
| R_size_t R_MinVFree = (R_size_t)(orig_R_VSize * R_MinFreeFrac); |
| R_size_t NNeeded = R_NodesInUse + R_MinNFree; |
| R_size_t VNeeded = R_SmallVallocSize + R_LargeVallocSize |
| + size_needed + R_MinVFree; |
| double node_occup = ((double) NNeeded) / R_NSize; |
| double vect_occup = ((double) VNeeded) / R_VSize; |
| |
| if (node_occup > R_NGrowFrac) { |
| R_size_t change = |
| (R_size_t)(R_NGrowIncrMin + R_NGrowIncrFrac * R_NSize); |
| |
| /* for early andjustments grow more agressively */ |
| static R_size_t last_in_use = 0; |
| static int adjust_count = 1; |
| if (adjust_count < 50) { |
| adjust_count++; |
| |
| /* estimate next in-use count by assuming linear growth */ |
| R_size_t next_in_use = R_NodesInUse + (R_NodesInUse - last_in_use); |
| last_in_use = R_NodesInUse; |
| |
| /* try to achieve and occupancy rate of R_NGrowFrac */ |
| R_size_t next_nsize = (R_size_t) (next_in_use / R_NGrowFrac); |
| if (next_nsize > R_NSize + change) |
| change = next_nsize - R_NSize; |
| } |
| |
| if (R_MaxNSize >= R_NSize + change) |
| R_NSize += change; |
| } |
| else if (node_occup < R_NShrinkFrac) { |
| R_NSize -= (R_size_t)(R_NShrinkIncrMin + R_NShrinkIncrFrac * R_NSize); |
| if (R_NSize < NNeeded) |
| R_NSize = (NNeeded < R_MaxNSize) ? NNeeded: R_MaxNSize; |
| if (R_NSize < orig_R_NSize) |
| R_NSize = orig_R_NSize; |
| } |
| |
| if (vect_occup > 1.0 && VNeeded < R_MaxVSize) |
| R_VSize = VNeeded; |
| if (vect_occup > R_VGrowFrac) { |
| R_size_t change = (R_size_t)(R_VGrowIncrMin + R_VGrowIncrFrac * R_VSize); |
| if (R_MaxVSize - R_VSize >= change) |
| R_VSize += change; |
| } |
| else if (vect_occup < R_VShrinkFrac) { |
| R_VSize -= (R_size_t)(R_VShrinkIncrMin + R_VShrinkIncrFrac * R_VSize); |
| if (R_VSize < VNeeded) |
| R_VSize = VNeeded; |
| if (R_VSize < orig_R_VSize) |
| R_VSize = orig_R_VSize; |
| } |
| |
| DEBUG_ADJUST_HEAP_PRINT(node_occup, vect_occup); |
| } |
| |
| |
| /* Managing Old-to-New References. */ |
| |
| #define AGE_NODE(s,g) do { \ |
| SEXP an__n__ = (s); \ |
| int an__g__ = (g); \ |
| if (an__n__ && NODE_GEN_IS_YOUNGER(an__n__, an__g__)) { \ |
| if (NODE_IS_MARKED(an__n__)) \ |
| R_GenHeap[NODE_CLASS(an__n__)].OldCount[NODE_GENERATION(an__n__)]--; \ |
| else \ |
| MARK_NODE(an__n__); \ |
| SET_NODE_GENERATION(an__n__, an__g__); \ |
| UNSNAP_NODE(an__n__); \ |
| SET_NEXT_NODE(an__n__, forwarded_nodes); \ |
| forwarded_nodes = an__n__; \ |
| } \ |
| } while (0) |
| |
| static void AgeNodeAndChildren(SEXP s, int gen) |
| { |
| SEXP forwarded_nodes = NULL; |
| AGE_NODE(s, gen); |
| while (forwarded_nodes != NULL) { |
| s = forwarded_nodes; |
| forwarded_nodes = NEXT_NODE(forwarded_nodes); |
| if (NODE_GENERATION(s) != gen) |
| REprintf("****snapping into wrong generation\n"); |
| SNAP_NODE(s, R_GenHeap[NODE_CLASS(s)].Old[gen]); |
| R_GenHeap[NODE_CLASS(s)].OldCount[gen]++; |
| DO_CHILDREN(s, AGE_NODE, gen); |
| } |
| } |
| |
| static void old_to_new(SEXP x, SEXP y) |
| { |
| #ifdef EXPEL_OLD_TO_NEW |
| AgeNodeAndChildren(y, NODE_GENERATION(x)); |
| #else |
| UNSNAP_NODE(x); |
| SNAP_NODE(x, R_GenHeap[NODE_CLASS(x)].OldToNew[NODE_GENERATION(x)]); |
| #endif |
| } |
| |
| #ifdef COMPUTE_REFCNT_VALUES |
| #define FIX_REFCNT(x, old, new) do { \ |
| if (TRACKREFS(x)) { \ |
| SEXP __old__ = (old); \ |
| SEXP __new__ = (new); \ |
| if (__old__ != __new__) { \ |
| if (__old__) DECREMENT_REFCNT(__old__); \ |
| if (__new__) INCREMENT_REFCNT(__new__); \ |
| } \ |
| } \ |
| } while (0) |
| #else |
| #define FIX_REFCNT(x, old, new) do {} while (0) |
| #endif |
| |
| #define CHECK_OLD_TO_NEW(x,y) do { \ |
| if (NODE_IS_OLDER(CHK(x), CHK(y))) old_to_new(x,y); } while (0) |
| |
| |
| /* Node Sorting. SortNodes attempts to improve locality of reference |
| by rearranging the free list to place nodes on the same place page |
| together and order nodes within pages. This involves a sweep of the |
| heap, so it should not be done too often, but doing it at least |
| occasionally does seem essential. Sorting on each full colllection is |
| probably sufficient. |
| */ |
| |
| #define SORT_NODES |
| #ifdef SORT_NODES |
| static void SortNodes(void) |
| { |
| SEXP s; |
| int i; |
| |
| for (i = 0; i < NUM_SMALL_NODE_CLASSES; i++) { |
| PAGE_HEADER *page; |
| int node_size = NODE_SIZE(i); |
| int page_count = (R_PAGE_SIZE - sizeof(PAGE_HEADER)) / node_size; |
| |
| SET_NEXT_NODE(R_GenHeap[i].New, R_GenHeap[i].New); |
| SET_PREV_NODE(R_GenHeap[i].New, R_GenHeap[i].New); |
| for (page = R_GenHeap[i].pages; page != NULL; page = page->next) { |
| int j; |
| char *data = PAGE_DATA(page); |
| |
| for (j = 0; j < page_count; j++, data += node_size) { |
| s = (SEXP) data; |
| if (! NODE_IS_MARKED(s)) |
| SNAP_NODE(s, R_GenHeap[i].New); |
| } |
| } |
| R_GenHeap[i].Free = NEXT_NODE(R_GenHeap[i].New); |
| } |
| } |
| #endif |
| |
| |
| /* Finalization and Weak References */ |
| |
| /* The design of this mechanism is very close to the one described in |
| "Stretching the storage manager: weak pointers and stable names in |
| Haskell" by Peyton Jones, Marlow, and Elliott (at |
| www.research.microsoft.com/Users/simonpj/papers/weak.ps.gz). --LT */ |
| |
| static SEXP R_weak_refs = NULL; |
| |
| #define READY_TO_FINALIZE_MASK 1 |
| |
| #define SET_READY_TO_FINALIZE(s) ((s)->sxpinfo.gp |= READY_TO_FINALIZE_MASK) |
| #define CLEAR_READY_TO_FINALIZE(s) ((s)->sxpinfo.gp &= ~READY_TO_FINALIZE_MASK) |
| #define IS_READY_TO_FINALIZE(s) ((s)->sxpinfo.gp & READY_TO_FINALIZE_MASK) |
| |
| #define FINALIZE_ON_EXIT_MASK 2 |
| |
| #define SET_FINALIZE_ON_EXIT(s) ((s)->sxpinfo.gp |= FINALIZE_ON_EXIT_MASK) |
| #define CLEAR_FINALIZE_ON_EXIT(s) ((s)->sxpinfo.gp &= ~FINALIZE_ON_EXIT_MASK) |
| #define FINALIZE_ON_EXIT(s) ((s)->sxpinfo.gp & FINALIZE_ON_EXIT_MASK) |
| |
| #define WEAKREF_SIZE 4 |
| #define WEAKREF_KEY(w) VECTOR_ELT(w, 0) |
| #define SET_WEAKREF_KEY(w, k) SET_VECTOR_ELT(w, 0, k) |
| #define WEAKREF_VALUE(w) VECTOR_ELT(w, 1) |
| #define SET_WEAKREF_VALUE(w, v) SET_VECTOR_ELT(w, 1, v) |
| #define WEAKREF_FINALIZER(w) VECTOR_ELT(w, 2) |
| #define SET_WEAKREF_FINALIZER(w, f) SET_VECTOR_ELT(w, 2, f) |
| #define WEAKREF_NEXT(w) VECTOR_ELT(w, 3) |
| #define SET_WEAKREF_NEXT(w, n) SET_VECTOR_ELT(w, 3, n) |
| |
| static SEXP MakeCFinalizer(R_CFinalizer_t cfun); |
| |
| static SEXP NewWeakRef(SEXP key, SEXP val, SEXP fin, Rboolean onexit) |
| { |
| SEXP w; |
| |
| switch (TYPEOF(key)) { |
| case NILSXP: |
| case ENVSXP: |
| case EXTPTRSXP: |
| case BCODESXP: |
| break; |
| default: error(_("can only weakly reference/finalize reference objects")); |
| } |
| |
| PROTECT(key); |
| PROTECT(val = MAYBE_REFERENCED(val) ? duplicate(val) : val); |
| PROTECT(fin); |
| w = allocVector(VECSXP, WEAKREF_SIZE); |
| SET_TYPEOF(w, WEAKREFSXP); |
| if (key != R_NilValue) { |
| /* If the key is R_NilValue we don't register the weak reference. |
| This is used in loading saved images. */ |
| SET_WEAKREF_KEY(w, key); |
| SET_WEAKREF_VALUE(w, val); |
| SET_WEAKREF_FINALIZER(w, fin); |
| SET_WEAKREF_NEXT(w, R_weak_refs); |
| CLEAR_READY_TO_FINALIZE(w); |
| if (onexit) |
| SET_FINALIZE_ON_EXIT(w); |
| else |
| CLEAR_FINALIZE_ON_EXIT(w); |
| R_weak_refs = w; |
| } |
| UNPROTECT(3); |
| return w; |
| } |
| |
| SEXP R_MakeWeakRef(SEXP key, SEXP val, SEXP fin, Rboolean onexit) |
| { |
| switch (TYPEOF(fin)) { |
| case NILSXP: |
| case CLOSXP: |
| case BUILTINSXP: |
| case SPECIALSXP: |
| break; |
| default: error(_("finalizer must be a function or NULL")); |
| } |
| return NewWeakRef(key, val, fin, onexit); |
| } |
| |
| SEXP R_MakeWeakRefC(SEXP key, SEXP val, R_CFinalizer_t fin, Rboolean onexit) |
| { |
| SEXP w; |
| PROTECT(key); |
| PROTECT(val); |
| w = NewWeakRef(key, val, MakeCFinalizer(fin), onexit); |
| UNPROTECT(2); |
| return w; |
| } |
| |
| static Rboolean R_finalizers_pending = FALSE; |
| static void CheckFinalizers(void) |
| { |
| SEXP s; |
| R_finalizers_pending = FALSE; |
| for (s = R_weak_refs; s != R_NilValue; s = WEAKREF_NEXT(s)) { |
| if (! NODE_IS_MARKED(WEAKREF_KEY(s)) && ! IS_READY_TO_FINALIZE(s)) |
| SET_READY_TO_FINALIZE(s); |
| if (IS_READY_TO_FINALIZE(s)) |
| R_finalizers_pending = TRUE; |
| } |
| } |
| |
| /* C finalizers are stored in a CHARSXP. It would be nice if we could |
| use EXTPTRSXP's but these only hold a void *, and function pointers |
| are not guaranteed to be compatible with a void *. There should be |
| a cleaner way of doing this, but this will do for now. --LT */ |
| /* Changed to RAWSXP in 2.8.0 */ |
| static Rboolean isCFinalizer(SEXP fun) |
| { |
| return TYPEOF(fun) == RAWSXP; |
| /*return TYPEOF(fun) == EXTPTRSXP;*/ |
| } |
| |
| static SEXP MakeCFinalizer(R_CFinalizer_t cfun) |
| { |
| SEXP s = allocVector(RAWSXP, sizeof(R_CFinalizer_t)); |
| *((R_CFinalizer_t *) RAW(s)) = cfun; |
| return s; |
| /*return R_MakeExternalPtr((void *) cfun, R_NilValue, R_NilValue);*/ |
| } |
| |
| static R_CFinalizer_t GetCFinalizer(SEXP fun) |
| { |
| return *((R_CFinalizer_t *) RAW(fun)); |
| /*return (R_CFinalizer_t) R_ExternalPtrAddr(fun);*/ |
| } |
| |
| SEXP R_WeakRefKey(SEXP w) |
| { |
| if (TYPEOF(w) != WEAKREFSXP) |
| error(_("not a weak reference")); |
| return WEAKREF_KEY(w); |
| } |
| |
| SEXP R_WeakRefValue(SEXP w) |
| { |
| SEXP v; |
| if (TYPEOF(w) != WEAKREFSXP) |
| error(_("not a weak reference")); |
| v = WEAKREF_VALUE(w); |
| if (v != R_NilValue) |
| ENSURE_NAMEDMAX(v); |
| return v; |
| } |
| |
| void R_RunWeakRefFinalizer(SEXP w) |
| { |
| SEXP key, fun, e; |
| if (TYPEOF(w) != WEAKREFSXP) |
| error(_("not a weak reference")); |
| key = WEAKREF_KEY(w); |
| fun = WEAKREF_FINALIZER(w); |
| SET_WEAKREF_KEY(w, R_NilValue); |
| SET_WEAKREF_VALUE(w, R_NilValue); |
| SET_WEAKREF_FINALIZER(w, R_NilValue); |
| if (! IS_READY_TO_FINALIZE(w)) |
| SET_READY_TO_FINALIZE(w); /* insures removal from list on next gc */ |
| PROTECT(key); |
| PROTECT(fun); |
| int oldintrsusp = R_interrupts_suspended; |
| R_interrupts_suspended = TRUE; |
| if (isCFinalizer(fun)) { |
| /* Must be a C finalizer. */ |
| R_CFinalizer_t cfun = GetCFinalizer(fun); |
| cfun(key); |
| } |
| else if (fun != R_NilValue) { |
| /* An R finalizer. */ |
| PROTECT(e = LCONS(fun, LCONS(key, R_NilValue))); |
| eval(e, R_GlobalEnv); |
| UNPROTECT(1); |
| } |
| R_interrupts_suspended = oldintrsusp; |
| UNPROTECT(2); |
| } |
| |
| static Rboolean RunFinalizers(void) |
| { |
| R_CHECK_THREAD; |
| /* Prevent this function from running again when already in |
| progress. Jumps can only occur inside the top level context |
| where they will be caught, so the flag is guaranteed to be |
| reset at the end. */ |
| static Rboolean running = FALSE; |
| if (running) return FALSE; |
| running = TRUE; |
| |
| volatile SEXP s, last; |
| volatile Rboolean finalizer_run = FALSE; |
| |
| for (s = R_weak_refs, last = R_NilValue; s != R_NilValue;) { |
| SEXP next = WEAKREF_NEXT(s); |
| if (IS_READY_TO_FINALIZE(s)) { |
| /**** use R_ToplevelExec here? */ |
| RCNTXT thiscontext; |
| RCNTXT * volatile saveToplevelContext; |
| volatile int savestack; |
| volatile SEXP topExp, oldHStack, oldRStack, oldRVal; |
| volatile Rboolean oldvis; |
| PROTECT(oldHStack = R_HandlerStack); |
| PROTECT(oldRStack = R_RestartStack); |
| PROTECT(oldRVal = R_ReturnedValue); |
| oldvis = R_Visible; |
| R_HandlerStack = R_NilValue; |
| R_RestartStack = R_NilValue; |
| |
| finalizer_run = TRUE; |
| |
| /* A top level context is established for the finalizer to |
| insure that any errors that might occur do not spill |
| into the call that triggered the collection. */ |
| begincontext(&thiscontext, CTXT_TOPLEVEL, R_NilValue, R_GlobalEnv, |
| R_BaseEnv, R_NilValue, R_NilValue); |
| saveToplevelContext = R_ToplevelContext; |
| PROTECT(topExp = R_CurrentExpr); |
| savestack = R_PPStackTop; |
| /* The value of 'next' is protected to make it safe |
| for this routine to be called recursively from a |
| gc triggered by a finalizer. */ |
| PROTECT(next); |
| if (! SETJMP(thiscontext.cjmpbuf)) { |
| R_GlobalContext = R_ToplevelContext = &thiscontext; |
| |
| /* The entry in the weak reference list is removed |
| before running the finalizer. This insures that a |
| finalizer is run only once, even if running it |
| raises an error. */ |
| if (last == R_NilValue) |
| R_weak_refs = next; |
| else |
| SET_WEAKREF_NEXT(last, next); |
| R_RunWeakRefFinalizer(s); |
| } |
| endcontext(&thiscontext); |
| UNPROTECT(1); /* next */ |
| R_ToplevelContext = saveToplevelContext; |
| R_PPStackTop = savestack; |
| R_CurrentExpr = topExp; |
| R_HandlerStack = oldHStack; |
| R_RestartStack = oldRStack; |
| R_ReturnedValue = oldRVal; |
| R_Visible = oldvis; |
| UNPROTECT(4);/* topExp, oldRVal, oldRStack, oldHStack */ |
| } |
| else last = s; |
| s = next; |
| } |
| running = FALSE; |
| R_finalizers_pending = FALSE; |
| return finalizer_run; |
| } |
| |
| void R_RunExitFinalizers(void) |
| { |
| SEXP s; |
| |
| R_checkConstants(TRUE); |
| |
| for (s = R_weak_refs; s != R_NilValue; s = WEAKREF_NEXT(s)) |
| if (FINALIZE_ON_EXIT(s)) |
| SET_READY_TO_FINALIZE(s); |
| RunFinalizers(); |
| } |
| |
| void R_RunPendingFinalizers(void) |
| { |
| if (R_finalizers_pending) |
| RunFinalizers(); |
| } |
| |
| void R_RegisterFinalizerEx(SEXP s, SEXP fun, Rboolean onexit) |
| { |
| R_MakeWeakRef(s, R_NilValue, fun, onexit); |
| } |
| |
| void R_RegisterFinalizer(SEXP s, SEXP fun) |
| { |
| R_RegisterFinalizerEx(s, fun, FALSE); |
| } |
| |
| void R_RegisterCFinalizerEx(SEXP s, R_CFinalizer_t fun, Rboolean onexit) |
| { |
| R_MakeWeakRefC(s, R_NilValue, fun, onexit); |
| } |
| |
| void R_RegisterCFinalizer(SEXP s, R_CFinalizer_t fun) |
| { |
| R_RegisterCFinalizerEx(s, fun, FALSE); |
| } |
| |
| /* R interface function */ |
| |
| SEXP attribute_hidden do_regFinaliz(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| int onexit; |
| |
| checkArity(op, args); |
| |
| if (TYPEOF(CAR(args)) != ENVSXP && TYPEOF(CAR(args)) != EXTPTRSXP) |
| error(_("first argument must be environment or external pointer")); |
| if (TYPEOF(CADR(args)) != CLOSXP) |
| error(_("second argument must be a function")); |
| |
| onexit = asLogical(CADDR(args)); |
| if(onexit == NA_LOGICAL) |
| error(_("third argument must be 'TRUE' or 'FALSE'")); |
| |
| R_RegisterFinalizerEx(CAR(args), CADR(args), onexit); |
| return R_NilValue; |
| } |
| |
| |
| /* The Generational Collector. */ |
| |
| #define PROCESS_NODES() do { \ |
| while (forwarded_nodes != NULL) { \ |
| s = forwarded_nodes; \ |
| forwarded_nodes = NEXT_NODE(forwarded_nodes); \ |
| SNAP_NODE(s, R_GenHeap[NODE_CLASS(s)].Old[NODE_GENERATION(s)]); \ |
| R_GenHeap[NODE_CLASS(s)].OldCount[NODE_GENERATION(s)]++; \ |
| FORWARD_CHILDREN(s); \ |
| } \ |
| } while (0) |
| |
| static int RunGenCollect(R_size_t size_needed) |
| { |
| int i, gen, gens_collected; |
| RCNTXT *ctxt; |
| SEXP s; |
| SEXP forwarded_nodes; |
| |
| bad_sexp_type_seen = 0; |
| |
| /* determine number of generations to collect */ |
| while (num_old_gens_to_collect < NUM_OLD_GENERATIONS) { |
| if (collect_counts[num_old_gens_to_collect]-- <= 0) { |
| collect_counts[num_old_gens_to_collect] = |
| collect_counts_max[num_old_gens_to_collect]; |
| num_old_gens_to_collect++; |
| } |
| else break; |
| } |
| |
| #ifdef PROTECTCHECK |
| num_old_gens_to_collect = NUM_OLD_GENERATIONS; |
| #endif |
| |
| again: |
| gens_collected = num_old_gens_to_collect; |
| |
| #ifndef EXPEL_OLD_TO_NEW |
| /* eliminate old-to-new references in generations to collect by |
| transferring referenced nodes to referring generation */ |
| for (gen = 0; gen < num_old_gens_to_collect; gen++) { |
| for (i = 0; i < NUM_NODE_CLASSES; i++) { |
| s = NEXT_NODE(R_GenHeap[i].OldToNew[gen]); |
| while (s != R_GenHeap[i].OldToNew[gen]) { |
| SEXP next = NEXT_NODE(s); |
| DO_CHILDREN(s, AgeNodeAndChildren, gen); |
| UNSNAP_NODE(s); |
| if (NODE_GENERATION(s) != gen) |
| REprintf("****snapping into wrong generation\n"); |
| SNAP_NODE(s, R_GenHeap[i].Old[gen]); |
| s = next; |
| } |
| } |
| } |
| #endif |
| |
| DEBUG_CHECK_NODE_COUNTS("at start"); |
| |
| /* unmark all marked nodes in old generations to be collected and |
| move to New space */ |
| for (gen = 0; gen < num_old_gens_to_collect; gen++) { |
| for (i = 0; i < NUM_NODE_CLASSES; i++) { |
| R_GenHeap[i].OldCount[gen] = 0; |
| s = NEXT_NODE(R_GenHeap[i].Old[gen]); |
| while (s != R_GenHeap[i].Old[gen]) { |
| SEXP next = NEXT_NODE(s); |
| if (gen < NUM_OLD_GENERATIONS - 1) |
| SET_NODE_GENERATION(s, gen + 1); |
| UNMARK_NODE(s); |
| s = next; |
| } |
| if (NEXT_NODE(R_GenHeap[i].Old[gen]) != R_GenHeap[i].Old[gen]) |
| BULK_MOVE(R_GenHeap[i].Old[gen], R_GenHeap[i].New); |
| } |
| } |
| |
| forwarded_nodes = NULL; |
| |
| #ifndef EXPEL_OLD_TO_NEW |
| /* scan nodes in uncollected old generations with old-to-new pointers */ |
| for (gen = num_old_gens_to_collect; gen < NUM_OLD_GENERATIONS; gen++) |
| for (i = 0; i < NUM_NODE_CLASSES; i++) |
| for (s = NEXT_NODE(R_GenHeap[i].OldToNew[gen]); |
| s != R_GenHeap[i].OldToNew[gen]; |
| s = NEXT_NODE(s)) |
| FORWARD_CHILDREN(s); |
| #endif |
| |
| /* forward all roots */ |
| FORWARD_NODE(R_NilValue); /* Builtin constants */ |
| FORWARD_NODE(NA_STRING); |
| FORWARD_NODE(R_BlankString); |
| FORWARD_NODE(R_BlankScalarString); |
| FORWARD_NODE(R_CurrentExpression); |
| FORWARD_NODE(R_UnboundValue); |
| FORWARD_NODE(R_RestartToken); |
| FORWARD_NODE(R_MissingArg); |
| FORWARD_NODE(R_InBCInterpreter); |
| |
| FORWARD_NODE(R_GlobalEnv); /* Global environment */ |
| FORWARD_NODE(R_BaseEnv); |
| FORWARD_NODE(R_EmptyEnv); |
| FORWARD_NODE(R_Warnings); /* Warnings, if any */ |
| FORWARD_NODE(R_ReturnedValue); |
| |
| FORWARD_NODE(R_HandlerStack); /* Condition handler stack */ |
| FORWARD_NODE(R_RestartStack); /* Available restarts stack */ |
| |
| FORWARD_NODE(R_BCbody); /* Current byte code object */ |
| FORWARD_NODE(R_Srcref); /* Current source reference */ |
| |
| FORWARD_NODE(R_TrueValue); |
| FORWARD_NODE(R_FalseValue); |
| FORWARD_NODE(R_LogicalNAValue); |
| |
| FORWARD_NODE(R_print.na_string); |
| FORWARD_NODE(R_print.na_string_noquote); |
| |
| if (R_SymbolTable != NULL) /* in case of GC during startup */ |
| for (i = 0; i < HSIZE; i++) { /* Symbol table */ |
| FORWARD_NODE(R_SymbolTable[i]); |
| SEXP s; |
| for (s = R_SymbolTable[i]; s != R_NilValue; s = CDR(s)) |
| if (ATTRIB(CAR(s)) != R_NilValue) |
| REprintf("****found a symbol with attributes\n"); |
| } |
| |
| if (R_CurrentExpr != NULL) /* Current expression */ |
| FORWARD_NODE(R_CurrentExpr); |
| |
| for (i = 0; i < R_MaxDevices; i++) { /* Device display lists */ |
| pGEDevDesc gdd = GEgetDevice(i); |
| if (gdd) { |
| FORWARD_NODE(gdd->displayList); |
| FORWARD_NODE(gdd->savedSnapshot); |
| if (gdd->dev) |
| FORWARD_NODE(gdd->dev->eventEnv); |
| } |
| } |
| |
| for (ctxt = R_GlobalContext ; ctxt != NULL ; ctxt = ctxt->nextcontext) { |
| FORWARD_NODE(ctxt->conexit); /* on.exit expressions */ |
| FORWARD_NODE(ctxt->promargs); /* promises supplied to closure */ |
| FORWARD_NODE(ctxt->callfun); /* the closure called */ |
| FORWARD_NODE(ctxt->sysparent); /* calling environment */ |
| FORWARD_NODE(ctxt->call); /* the call */ |
| FORWARD_NODE(ctxt->cloenv); /* the closure environment */ |
| FORWARD_NODE(ctxt->bcbody); /* the current byte code object */ |
| FORWARD_NODE(ctxt->handlerstack); /* the condition handler stack */ |
| FORWARD_NODE(ctxt->restartstack); /* the available restarts stack */ |
| FORWARD_NODE(ctxt->srcref); /* the current source reference */ |
| FORWARD_NODE(ctxt->returnValue); /* For on.exit calls */ |
| } |
| |
| FORWARD_NODE(R_PreciousList); |
| |
| for (i = 0; i < R_PPStackTop; i++) /* Protected pointers */ |
| FORWARD_NODE(R_PPStack[i]); |
| |
| FORWARD_NODE(R_VStack); /* R_alloc stack */ |
| |
| for (R_bcstack_t *sp = R_BCNodeStackBase; sp < R_BCNodeStackTop; sp++) { |
| if (sp->tag == RAWMEM_TAG) |
| sp += sp->u.ival; |
| else if (sp->tag == 0 || IS_PARTIAL_SXP_TAG(sp->tag)) |
| FORWARD_NODE(sp->u.sxpval); |
| } |
| |
| /* main processing loop */ |
| PROCESS_NODES(); |
| |
| /* identify weakly reachable nodes */ |
| { |
| Rboolean recheck_weak_refs; |
| do { |
| recheck_weak_refs = FALSE; |
| for (s = R_weak_refs; s != R_NilValue; s = WEAKREF_NEXT(s)) { |
| if (NODE_IS_MARKED(WEAKREF_KEY(s))) { |
| if (! NODE_IS_MARKED(WEAKREF_VALUE(s))) { |
| recheck_weak_refs = TRUE; |
| FORWARD_NODE(WEAKREF_VALUE(s)); |
| } |
| if (! NODE_IS_MARKED(WEAKREF_FINALIZER(s))) { |
| recheck_weak_refs = TRUE; |
| FORWARD_NODE(WEAKREF_FINALIZER(s)); |
| } |
| } |
| } |
| PROCESS_NODES(); |
| } while (recheck_weak_refs); |
| } |
| |
| /* mark nodes ready for finalizing */ |
| CheckFinalizers(); |
| |
| /* process the weak reference chain */ |
| for (s = R_weak_refs; s != R_NilValue; s = WEAKREF_NEXT(s)) { |
| FORWARD_NODE(s); |
| FORWARD_NODE(WEAKREF_KEY(s)); |
| FORWARD_NODE(WEAKREF_VALUE(s)); |
| FORWARD_NODE(WEAKREF_FINALIZER(s)); |
| } |
| PROCESS_NODES(); |
| |
| DEBUG_CHECK_NODE_COUNTS("after processing forwarded list"); |
| |
| /* process CHARSXP cache */ |
| if (R_StringHash != NULL) /* in case of GC during initialization */ |
| { |
| SEXP t; |
| int nc = 0; |
| for (i = 0; i < LENGTH(R_StringHash); i++) { |
| s = VECTOR_ELT(R_StringHash, i); |
| t = R_NilValue; |
| while (s != R_NilValue) { |
| if (! NODE_IS_MARKED(CXHEAD(s))) { /* remove unused CHARSXP and cons cell */ |
| if (t == R_NilValue) /* head of list */ |
| VECTOR_ELT(R_StringHash, i) = CXTAIL(s); |
| else |
| CXTAIL(t) = CXTAIL(s); |
| s = CXTAIL(s); |
| continue; |
| } |
| FORWARD_NODE(s); |
| FORWARD_NODE(CXHEAD(s)); |
| t = s; |
| s = CXTAIL(s); |
| } |
| if(VECTOR_ELT(R_StringHash, i) != R_NilValue) nc++; |
| } |
| SET_TRUELENGTH(R_StringHash, nc); /* SET_HASHPRI, really */ |
| } |
| FORWARD_NODE(R_StringHash); |
| PROCESS_NODES(); |
| |
| #ifdef PROTECTCHECK |
| for(i=0; i< NUM_SMALL_NODE_CLASSES;i++){ |
| s = NEXT_NODE(R_GenHeap[i].New); |
| while (s != R_GenHeap[i].New) { |
| SEXP next = NEXT_NODE(s); |
| if (TYPEOF(s) != NEWSXP) { |
| if (TYPEOF(s) != FREESXP) { |
| SETOLDTYPE(s, TYPEOF(s)); |
| SET_TYPEOF(s, FREESXP); |
| } |
| if (gc_inhibit_release) |
| FORWARD_NODE(s); |
| } |
| s = next; |
| } |
| } |
| for (i = CUSTOM_NODE_CLASS; i <= LARGE_NODE_CLASS; i++) { |
| s = NEXT_NODE(R_GenHeap[i].New); |
| while (s != R_GenHeap[i].New) { |
| SEXP next = NEXT_NODE(s); |
| if (TYPEOF(s) != NEWSXP) { |
| if (TYPEOF(s) != FREESXP) { |
| /**** could also leave this alone and restore the old |
| node type in ReleaseLargeFreeVectors before |
| calculating size */ |
| if (CHAR(s) != NULL) { |
| R_size_t size = getVecSizeInVEC(s); |
| SET_STDVEC_LENGTH(s, size); |
| } |
| SETOLDTYPE(s, TYPEOF(s)); |
| SET_TYPEOF(s, FREESXP); |
| } |
| if (gc_inhibit_release) |
| FORWARD_NODE(s); |
| } |
| s = next; |
| } |
| } |
| if (gc_inhibit_release) |
| PROCESS_NODES(); |
| #endif |
| |
| /* release large vector allocations */ |
| ReleaseLargeFreeVectors(); |
| |
| DEBUG_CHECK_NODE_COUNTS("after releasing large allocated nodes"); |
| |
| /* tell Valgrind about free nodes */ |
| #if VALGRIND_LEVEL > 1 |
| for(i = 1; i< NUM_NODE_CLASSES; i++) { |
| for(s = NEXT_NODE(R_GenHeap[i].New); |
| s != R_GenHeap[i].Free; |
| s = NEXT_NODE(s)) { |
| VALGRIND_MAKE_MEM_NOACCESS(STDVEC_DATAPTR(s), |
| NodeClassSize[i]*sizeof(VECREC)); |
| } |
| } |
| #endif |
| |
| /* reset Free pointers */ |
| for (i = 0; i < NUM_NODE_CLASSES; i++) |
| R_GenHeap[i].Free = NEXT_NODE(R_GenHeap[i].New); |
| |
| |
| /* update heap statistics */ |
| R_Collected = R_NSize; |
| R_SmallVallocSize = 0; |
| for (gen = 0; gen < NUM_OLD_GENERATIONS; gen++) { |
| for (i = 1; i < NUM_SMALL_NODE_CLASSES; i++) |
| R_SmallVallocSize += R_GenHeap[i].OldCount[gen] * NodeClassSize[i]; |
| for (i = 0; i < NUM_NODE_CLASSES; i++) |
| R_Collected -= R_GenHeap[i].OldCount[gen]; |
| } |
| R_NodesInUse = R_NSize - R_Collected; |
| |
| if (num_old_gens_to_collect < NUM_OLD_GENERATIONS) { |
| if (R_Collected < R_MinFreeFrac * R_NSize || |
| VHEAP_FREE() < size_needed + R_MinFreeFrac * R_VSize) { |
| num_old_gens_to_collect++; |
| if (R_Collected <= 0 || VHEAP_FREE() < size_needed) |
| goto again; |
| } |
| else num_old_gens_to_collect = 0; |
| } |
| else num_old_gens_to_collect = 0; |
| |
| gen_gc_counts[gens_collected]++; |
| |
| if (gens_collected == NUM_OLD_GENERATIONS) { |
| /**** do some adjustment for intermediate collections? */ |
| AdjustHeapSize(size_needed); |
| TryToReleasePages(); |
| DEBUG_CHECK_NODE_COUNTS("after heap adjustment"); |
| } |
| else if (gens_collected > 0) { |
| TryToReleasePages(); |
| DEBUG_CHECK_NODE_COUNTS("after heap adjustment"); |
| } |
| #ifdef SORT_NODES |
| if (gens_collected == NUM_OLD_GENERATIONS) |
| SortNodes(); |
| #endif |
| |
| if (gc_reporting) { |
| REprintf("Garbage collection %d = %d", gc_count, gen_gc_counts[0]); |
| for (int i = 0; i < NUM_OLD_GENERATIONS; i++) |
| REprintf("+%d", gen_gc_counts[i + 1]); |
| REprintf(" (level %d) ... ", gens_collected); |
| DEBUG_GC_SUMMARY(gens_collected == NUM_OLD_GENERATIONS); |
| } |
| return gens_collected; |
| } |
| |
| |
| /* public interface for controlling GC torture settings */ |
| /* maybe, but in no header */ |
| void R_gc_torture(int gap, int wait, Rboolean inhibit) |
| { |
| if (gap != NA_INTEGER && gap >= 0) |
| gc_force_wait = gc_force_gap = gap; |
| if (gap > 0) { |
| if (wait != NA_INTEGER && wait > 0) |
| gc_force_wait = wait; |
| } |
| #ifdef PROTECTCHECK |
| if (gap > 0) { |
| if (inhibit != NA_LOGICAL) |
| gc_inhibit_release = inhibit; |
| } |
| else gc_inhibit_release = FALSE; |
| #endif |
| } |
| |
| SEXP attribute_hidden do_gctorture(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| int gap; |
| SEXP old = ScalarLogical(gc_force_wait > 0); |
| |
| checkArity(op, args); |
| |
| if (isLogical(CAR(args))) { |
| Rboolean on = asLogical(CAR(args)); |
| if (on == NA_LOGICAL) gap = NA_INTEGER; |
| else if (on) gap = 1; |
| else gap = 0; |
| } |
| else gap = asInteger(CAR(args)); |
| |
| R_gc_torture(gap, 0, FALSE); |
| |
| return old; |
| } |
| |
| SEXP attribute_hidden do_gctorture2(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| int gap, wait; |
| Rboolean inhibit; |
| int old = gc_force_gap; |
| |
| checkArity(op, args); |
| gap = asInteger(CAR(args)); |
| wait = asInteger(CADR(args)); |
| inhibit = asLogical(CADDR(args)); |
| R_gc_torture(gap, wait, inhibit); |
| |
| return ScalarInteger(old); |
| } |
| |
| /* initialize gctorture settings from environment variables */ |
| static void init_gctorture(void) |
| { |
| char *arg = getenv("R_GCTORTURE"); |
| if (arg != NULL) { |
| int gap = atoi(arg); |
| if (gap > 0) { |
| gc_force_wait = gc_force_gap = gap; |
| arg = getenv("R_GCTORTURE_WAIT"); |
| if (arg != NULL) { |
| int wait = atoi(arg); |
| if (wait > 0) |
| gc_force_wait = wait; |
| } |
| #ifdef PROTECTCHECK |
| arg = getenv("R_GCTORTURE_INHIBIT_RELEASE"); |
| if (arg != NULL) { |
| int inhibit = atoi(arg); |
| if (inhibit > 0) gc_inhibit_release = TRUE; |
| else gc_inhibit_release = FALSE; |
| } |
| #endif |
| } |
| } |
| } |
| |
| SEXP attribute_hidden do_gcinfo(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| int i; |
| SEXP old = ScalarLogical(gc_reporting); |
| checkArity(op, args); |
| i = asLogical(CAR(args)); |
| if (i != NA_LOGICAL) |
| gc_reporting = i; |
| return old; |
| } |
| |
| /* reports memory use to profiler in eval.c */ |
| |
| void attribute_hidden get_current_mem(size_t *smallvsize, |
| size_t *largevsize, |
| size_t *nodes) |
| { |
| *smallvsize = R_SmallVallocSize; |
| *largevsize = R_LargeVallocSize; |
| *nodes = R_NodesInUse * sizeof(SEXPREC); |
| return; |
| } |
| |
| SEXP attribute_hidden do_gc(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP value; |
| int ogc, reset_max, full; |
| R_size_t onsize = R_NSize /* can change during collection */; |
| |
| checkArity(op, args); |
| ogc = gc_reporting; |
| gc_reporting = asLogical(CAR(args)); |
| reset_max = asLogical(CADR(args)); |
| full = asLogical(CADDR(args)); |
| if (full) |
| R_gc(); |
| else |
| R_gc_lite(); |
| |
| gc_reporting = ogc; |
| /*- now return the [used , gc trigger size] for cells and heap */ |
| PROTECT(value = allocVector(REALSXP, 14)); |
| REAL(value)[0] = onsize - R_Collected; |
| REAL(value)[1] = R_VSize - VHEAP_FREE(); |
| REAL(value)[4] = R_NSize; |
| REAL(value)[5] = R_VSize; |
| /* next four are in 0.1Mb, rounded up */ |
| REAL(value)[2] = 0.1*ceil(10. * (onsize - R_Collected)/Mega * sizeof(SEXPREC)); |
| REAL(value)[3] = 0.1*ceil(10. * (R_VSize - VHEAP_FREE())/Mega * vsfac); |
| REAL(value)[6] = 0.1*ceil(10. * R_NSize/Mega * sizeof(SEXPREC)); |
| REAL(value)[7] = 0.1*ceil(10. * R_VSize/Mega * vsfac); |
| REAL(value)[8] = (R_MaxNSize < R_SIZE_T_MAX) ? |
| 0.1*ceil(10. * R_MaxNSize/Mega * sizeof(SEXPREC)) : NA_REAL; |
| REAL(value)[9] = (R_MaxVSize < R_SIZE_T_MAX) ? |
| 0.1*ceil(10. * R_MaxVSize/Mega * vsfac) : NA_REAL; |
| if (reset_max){ |
| R_N_maxused = onsize - R_Collected; |
| R_V_maxused = R_VSize - VHEAP_FREE(); |
| } |
| REAL(value)[10] = R_N_maxused; |
| REAL(value)[11] = R_V_maxused; |
| REAL(value)[12] = 0.1*ceil(10. * R_N_maxused/Mega*sizeof(SEXPREC)); |
| REAL(value)[13] = 0.1*ceil(10. * R_V_maxused/Mega*vsfac); |
| UNPROTECT(1); |
| return value; |
| } |
| |
| |
| static void NORET mem_err_heap(R_size_t size) |
| { |
| errorcall(R_NilValue, _("vector memory exhausted (limit reached?)")); |
| } |
| |
| |
| static void NORET mem_err_cons(void) |
| { |
| errorcall(R_NilValue, _("cons memory exhausted (limit reached?)")); |
| } |
| |
| static void NORET mem_err_malloc(R_size_t size) |
| { |
| errorcall(R_NilValue, _("memory exhausted (limit reached?)")); |
| } |
| |
| /* InitMemory : Initialise the memory to be used in R. */ |
| /* This includes: stack space, node space and vector space */ |
| |
| #define PP_REDZONE_SIZE 1000L |
| static int R_StandardPPStackSize, R_RealPPStackSize; |
| |
| void attribute_hidden InitMemory() |
| { |
| int i; |
| int gen; |
| |
| init_gctorture(); |
| init_gc_grow_settings(); |
| |
| gc_reporting = R_Verbose; |
| R_StandardPPStackSize = R_PPStackSize; |
| R_RealPPStackSize = R_PPStackSize + PP_REDZONE_SIZE; |
| if (!(R_PPStack = (SEXP *) malloc(R_RealPPStackSize * sizeof(SEXP)))) |
| R_Suicide("couldn't allocate memory for pointer stack"); |
| R_PPStackTop = 0; |
| #if VALGRIND_LEVEL > 1 |
| VALGRIND_MAKE_MEM_NOACCESS(R_PPStack+R_PPStackSize, PP_REDZONE_SIZE); |
| #endif |
| vsfac = sizeof(VECREC); |
| R_VSize = (R_VSize + 1)/vsfac; |
| if (R_MaxVSize < R_SIZE_T_MAX) R_MaxVSize = (R_MaxVSize + 1)/vsfac; |
| |
| UNMARK_NODE(&UnmarkedNodeTemplate); |
| |
| for (i = 0; i < NUM_NODE_CLASSES; i++) { |
| for (gen = 0; gen < NUM_OLD_GENERATIONS; gen++) { |
| R_GenHeap[i].Old[gen] = &R_GenHeap[i].OldPeg[gen]; |
| SET_PREV_NODE(R_GenHeap[i].Old[gen], R_GenHeap[i].Old[gen]); |
| SET_NEXT_NODE(R_GenHeap[i].Old[gen], R_GenHeap[i].Old[gen]); |
| |
| #ifndef EXPEL_OLD_TO_NEW |
| R_GenHeap[i].OldToNew[gen] = &R_GenHeap[i].OldToNewPeg[gen]; |
| SET_PREV_NODE(R_GenHeap[i].OldToNew[gen], R_GenHeap[i].OldToNew[gen]); |
| SET_NEXT_NODE(R_GenHeap[i].OldToNew[gen], R_GenHeap[i].OldToNew[gen]); |
| #endif |
| |
| R_GenHeap[i].OldCount[gen] = 0; |
| } |
| R_GenHeap[i].New = &R_GenHeap[i].NewPeg; |
| SET_PREV_NODE(R_GenHeap[i].New, R_GenHeap[i].New); |
| SET_NEXT_NODE(R_GenHeap[i].New, R_GenHeap[i].New); |
| } |
| |
| for (i = 0; i < NUM_NODE_CLASSES; i++) |
| R_GenHeap[i].Free = NEXT_NODE(R_GenHeap[i].New); |
| |
| SET_NODE_CLASS(&UnmarkedNodeTemplate, 0); |
| orig_R_NSize = R_NSize; |
| orig_R_VSize = R_VSize; |
| |
| /* R_NilValue */ |
| /* THIS MUST BE THE FIRST CONS CELL ALLOCATED */ |
| /* OR ARMAGEDDON HAPPENS. */ |
| /* Field assignments for R_NilValue must not go through write barrier |
| since the write barrier prevents assignments to R_NilValue's fields. |
| because of checks for nil */ |
| GET_FREE_NODE(R_NilValue); |
| R_NilValue->sxpinfo = UnmarkedNodeTemplate.sxpinfo; |
| INIT_REFCNT(R_NilValue); |
| SET_REFCNT(R_NilValue, REFCNTMAX); |
| SET_TYPEOF(R_NilValue, NILSXP); |
| CAR(R_NilValue) = R_NilValue; |
| CDR(R_NilValue) = R_NilValue; |
| TAG(R_NilValue) = R_NilValue; |
| ATTRIB(R_NilValue) = R_NilValue; |
| MARK_NOT_MUTABLE(R_NilValue); |
| |
| R_BCNodeStackBase = |
| (R_bcstack_t *) malloc(R_BCNODESTACKSIZE * sizeof(R_bcstack_t)); |
| if (R_BCNodeStackBase == NULL) |
| R_Suicide("couldn't allocate node stack"); |
| R_BCNodeStackTop = R_BCNodeStackBase; |
| R_BCNodeStackEnd = R_BCNodeStackBase + R_BCNODESTACKSIZE; |
| |
| R_weak_refs = R_NilValue; |
| |
| R_HandlerStack = R_RestartStack = R_NilValue; |
| |
| /* Unbound values which are to be preserved through GCs */ |
| R_PreciousList = R_NilValue; |
| |
| /* The current source line */ |
| R_Srcref = R_NilValue; |
| |
| /* R_TrueValue and R_FalseValue */ |
| R_TrueValue = mkTrue(); |
| MARK_NOT_MUTABLE(R_TrueValue); |
| R_FalseValue = mkFalse(); |
| MARK_NOT_MUTABLE(R_FalseValue); |
| R_LogicalNAValue = allocVector(LGLSXP, 1); |
| LOGICAL(R_LogicalNAValue)[0] = NA_LOGICAL; |
| MARK_NOT_MUTABLE(R_LogicalNAValue); |
| } |
| |
| /* Since memory allocated from the heap is non-moving, R_alloc just |
| allocates off the heap as RAWSXP/REALSXP and maintains the stack of |
| allocations through the ATTRIB pointer. The stack pointer R_VStack |
| is traced by the collector. */ |
| void *vmaxget(void) |
| { |
| return (void *) R_VStack; |
| } |
| |
| void vmaxset(const void *ovmax) |
| { |
| R_VStack = (SEXP) ovmax; |
| } |
| |
| char *R_alloc(size_t nelem, int eltsize) |
| { |
| R_size_t size = nelem * eltsize; |
| /* doubles are a precaution against integer overflow on 32-bit */ |
| double dsize = (double) nelem * eltsize; |
| if (dsize > 0) { |
| SEXP s; |
| #ifdef LONG_VECTOR_SUPPORT |
| /* 64-bit platform: previous version used REALSXPs */ |
| if(dsize > R_XLEN_T_MAX) /* currently 4096 TB */ |
| error(_("cannot allocate memory block of size %0.f Tb"), |
| dsize/R_pow_di(1024.0, 4)); |
| s = allocVector(RAWSXP, size + 1); |
| #else |
| if(dsize > R_LEN_T_MAX) /* must be in the Gb range */ |
| error(_("cannot allocate memory block of size %0.1f Gb"), |
| dsize/R_pow_di(1024.0, 3)); |
| s = allocVector(RAWSXP, size + 1); |
| #endif |
| ATTRIB(s) = R_VStack; |
| R_VStack = s; |
| return (char *) DATAPTR(s); |
| } |
| /* One programmer has relied on this, but it is undocumented! */ |
| else return NULL; |
| } |
| |
| #ifdef HAVE_STDALIGN_H |
| # include <stdalign.h> |
| #endif |
| |
| #include <stdint.h> |
| |
| long double *R_allocLD(size_t nelem) |
| { |
| #if __alignof_is_defined |
| // This is C11: picky compilers may warn. |
| size_t ld_align = alignof(long double); |
| #elif __GNUC__ |
| // This is C99, but do not rely on it. |
| size_t ld_align = offsetof(struct { char __a; long double __b; }, __b); |
| #else |
| size_t ld_align = 0x0F; // value of x86_64, known others are 4 or 8 |
| #endif |
| if (ld_align > 8) { |
| uintptr_t tmp = (uintptr_t) R_alloc(nelem + 1, sizeof(long double)); |
| tmp = (tmp + ld_align - 1) & ~ld_align; |
| return (long double *) tmp; |
| } else { |
| return (long double *) R_alloc(nelem, sizeof(long double)); |
| } |
| } |
| |
| |
| /* S COMPATIBILITY */ |
| |
| char *S_alloc(long nelem, int eltsize) |
| { |
| R_size_t size = nelem * eltsize; |
| char *p = R_alloc(nelem, eltsize); |
| |
| if(p) memset(p, 0, size); |
| return p; |
| } |
| |
| |
| char *S_realloc(char *p, long new, long old, int size) |
| { |
| size_t nold; |
| char *q; |
| /* shrinking is a no-op */ |
| if(new <= old) return p; // so nnew > 0 below |
| q = R_alloc((size_t)new, size); |
| nold = (size_t)old * size; |
| memcpy(q, p, nold); |
| memset(q + nold, 0, (size_t)new*size - nold); |
| return q; |
| } |
| |
| |
| /* Allocation functions that GC on initial failure */ |
| |
| void *R_malloc_gc(size_t n) |
| { |
| void *np = malloc(n); |
| if (np == NULL) { |
| R_gc(); |
| np = malloc(n); |
| } |
| return np; |
| } |
| |
| void *R_calloc_gc(size_t n, size_t s) |
| { |
| void *np = calloc(n, s); |
| if (np == NULL) { |
| R_gc(); |
| np = calloc(n, s); |
| } |
| return np; |
| } |
| |
| void *R_realloc_gc(void *p, size_t n) |
| { |
| void *np = realloc(p, n); |
| if (np == NULL) { |
| R_gc(); |
| np = realloc(p, n); |
| } |
| return np; |
| } |
| |
| |
| /* "allocSExp" allocate a SEXPREC */ |
| /* call gc if necessary */ |
| |
| SEXP allocSExp(SEXPTYPE t) |
| { |
| SEXP s; |
| if (FORCE_GC || NO_FREE_NODES()) { |
| R_gc_internal(0); |
| if (NO_FREE_NODES()) |
| mem_err_cons(); |
| } |
| GET_FREE_NODE(s); |
| s->sxpinfo = UnmarkedNodeTemplate.sxpinfo; |
| INIT_REFCNT(s); |
| SET_TYPEOF(s, t); |
| CAR(s) = R_NilValue; |
| CDR(s) = R_NilValue; |
| TAG(s) = R_NilValue; |
| ATTRIB(s) = R_NilValue; |
| return s; |
| } |
| |
| static SEXP allocSExpNonCons(SEXPTYPE t) |
| { |
| SEXP s; |
| if (FORCE_GC || NO_FREE_NODES()) { |
| R_gc_internal(0); |
| if (NO_FREE_NODES()) |
| mem_err_cons(); |
| } |
| GET_FREE_NODE(s); |
| s->sxpinfo = UnmarkedNodeTemplate.sxpinfo; |
| INIT_REFCNT(s); |
| SET_TYPEOF(s, t); |
| TAG(s) = R_NilValue; |
| ATTRIB(s) = R_NilValue; |
| return s; |
| } |
| |
| /* cons is defined directly to avoid the need to protect its arguments |
| unless a GC will actually occur. */ |
| SEXP cons(SEXP car, SEXP cdr) |
| { |
| SEXP s; |
| if (FORCE_GC || NO_FREE_NODES()) { |
| PROTECT(car); |
| PROTECT(cdr); |
| R_gc_internal(0); |
| UNPROTECT(2); |
| if (NO_FREE_NODES()) |
| mem_err_cons(); |
| } |
| |
| if (NEED_NEW_PAGE()) { |
| PROTECT(car); |
| PROTECT(cdr); |
| GET_FREE_NODE(s); |
| UNPROTECT(2); |
| } |
| else |
| QUICK_GET_FREE_NODE(s); |
| |
| s->sxpinfo = UnmarkedNodeTemplate.sxpinfo; |
| INIT_REFCNT(s); |
| SET_TYPEOF(s, LISTSXP); |
| CAR(s) = CHK(car); if (car) INCREMENT_REFCNT(car); |
| CDR(s) = CHK(cdr); if (cdr) INCREMENT_REFCNT(cdr); |
| TAG(s) = R_NilValue; |
| ATTRIB(s) = R_NilValue; |
| return s; |
| } |
| |
| SEXP CONS_NR(SEXP car, SEXP cdr) |
| { |
| SEXP s; |
| if (FORCE_GC || NO_FREE_NODES()) { |
| PROTECT(car); |
| PROTECT(cdr); |
| R_gc_internal(0); |
| UNPROTECT(2); |
| if (NO_FREE_NODES()) |
| mem_err_cons(); |
| } |
| |
| if (NEED_NEW_PAGE()) { |
| PROTECT(car); |
| PROTECT(cdr); |
| GET_FREE_NODE(s); |
| UNPROTECT(2); |
| } |
| else |
| QUICK_GET_FREE_NODE(s); |
| |
| s->sxpinfo = UnmarkedNodeTemplate.sxpinfo; |
| INIT_REFCNT(s); |
| DISABLE_REFCNT(s); |
| SET_TYPEOF(s, LISTSXP); |
| CAR(s) = CHK(car); |
| CDR(s) = CHK(cdr); |
| TAG(s) = R_NilValue; |
| ATTRIB(s) = R_NilValue; |
| return s; |
| } |
| |
| /*---------------------------------------------------------------------- |
| |
| NewEnvironment |
| |
| Create an environment by extending "rho" with a frame obtained by |
| pairing the variable names given by the tags on "namelist" with |
| the values given by the elements of "valuelist". |
| |
| NewEnvironment is defined directly to avoid the need to protect its |
| arguments unless a GC will actually occur. This definition allows |
| the namelist argument to be shorter than the valuelist; in this |
| case the remaining values must be named already. (This is useful |
| in cases where the entire valuelist is already named--namelist can |
| then be R_NilValue.) |
| |
| The valuelist is destructively modified and used as the |
| environment's frame. |
| */ |
| SEXP NewEnvironment(SEXP namelist, SEXP valuelist, SEXP rho) |
| { |
| SEXP v, n, newrho; |
| |
| if (FORCE_GC || NO_FREE_NODES()) { |
| PROTECT(namelist); |
| PROTECT(valuelist); |
| PROTECT(rho); |
| R_gc_internal(0); |
| UNPROTECT(3); |
| if (NO_FREE_NODES()) |
| mem_err_cons(); |
| } |
| |
| if (NEED_NEW_PAGE()) { |
| PROTECT(namelist); |
| PROTECT(valuelist); |
| PROTECT(rho); |
| GET_FREE_NODE(newrho); |
| UNPROTECT(3); |
| } |
| else |
| QUICK_GET_FREE_NODE(newrho); |
| |
| newrho->sxpinfo = UnmarkedNodeTemplate.sxpinfo; |
| INIT_REFCNT(newrho); |
| SET_TYPEOF(newrho, ENVSXP); |
| FRAME(newrho) = valuelist; INCREMENT_REFCNT(valuelist); |
| ENCLOS(newrho) = CHK(rho); if (rho != NULL) INCREMENT_REFCNT(rho); |
| HASHTAB(newrho) = R_NilValue; |
| ATTRIB(newrho) = R_NilValue; |
| |
| v = CHK(valuelist); |
| n = CHK(namelist); |
| while (v != R_NilValue && n != R_NilValue) { |
| SET_TAG(v, TAG(n)); |
| v = CDR(v); |
| n = CDR(n); |
| } |
| return (newrho); |
| } |
| |
| /* mkPROMISE is defined directly do avoid the need to protect its arguments |
| unless a GC will actually occur. */ |
| SEXP attribute_hidden mkPROMISE(SEXP expr, SEXP rho) |
| { |
| SEXP s; |
| if (FORCE_GC || NO_FREE_NODES()) { |
| PROTECT(expr); |
| PROTECT(rho); |
| R_gc_internal(0); |
| UNPROTECT(2); |
| if (NO_FREE_NODES()) |
| mem_err_cons(); |
| } |
| |
| if (NEED_NEW_PAGE()) { |
| PROTECT(expr); |
| PROTECT(rho); |
| GET_FREE_NODE(s); |
| UNPROTECT(2); |
| } |
| else |
| QUICK_GET_FREE_NODE(s); |
| |
| /* precaution to ensure code does not get modified via |
| substitute() and the like */ |
| ENSURE_NAMEDMAX(expr); |
| |
| s->sxpinfo = UnmarkedNodeTemplate.sxpinfo; |
| INIT_REFCNT(s); |
| SET_TYPEOF(s, PROMSXP); |
| PRCODE(s) = CHK(expr); INCREMENT_REFCNT(expr); |
| PRENV(s) = CHK(rho); INCREMENT_REFCNT(rho); |
| PRVALUE(s) = R_UnboundValue; |
| PRSEEN(s) = 0; |
| ATTRIB(s) = R_NilValue; |
| return s; |
| } |
| |
| SEXP R_mkEVPROMISE(SEXP expr, SEXP val) |
| { |
| SEXP prom = mkPROMISE(expr, R_NilValue); |
| SET_PRVALUE(prom, val); |
| return prom; |
| } |
| |
| SEXP R_mkEVPROMISE_NR(SEXP expr, SEXP val) |
| { |
| SEXP prom = mkPROMISE(expr, R_NilValue); |
| DISABLE_REFCNT(prom); |
| SET_PRVALUE(prom, val); |
| return prom; |
| } |
| |
| /* support for custom allocators that allow vectors to be allocated |
| using non-standard means such as COW mmap() */ |
| |
| static void *custom_node_alloc(R_allocator_t *allocator, size_t size) { |
| if (!allocator || !allocator->mem_alloc) return NULL; |
| void *ptr = allocator->mem_alloc(allocator, size + sizeof(R_allocator_t)); |
| if (ptr) { |
| R_allocator_t *ca = (R_allocator_t*) ptr; |
| *ca = *allocator; |
| return (void*) (ca + 1); |
| } |
| return NULL; |
| } |
| |
| static void custom_node_free(void *ptr) { |
| if (ptr) { |
| R_allocator_t *allocator = ((R_allocator_t*) ptr) - 1; |
| allocator->mem_free(allocator, (void*)allocator); |
| } |
| } |
| |
| /* All vector objects must be a multiple of sizeof(SEXPREC_ALIGN) |
| bytes so that alignment is preserved for all objects */ |
| |
| /* Allocate a vector object (and also list-like objects). |
| This ensures only validity of list-like (LISTSXP, VECSXP, EXPRSXP), |
| STRSXP and CHARSXP types; e.g., atomic types remain un-initialized |
| and must be initialized upstream, e.g., in do_makevector(). |
| */ |
| #define intCHARSXP 73 |
| |
| SEXP allocVector3(SEXPTYPE type, R_xlen_t length, R_allocator_t *allocator) |
| { |
| SEXP s; /* For the generational collector it would be safer to |
| work in terms of a VECSEXP here, but that would |
| require several casts below... */ |
| R_size_t size = 0, alloc_size, old_R_VSize; |
| int node_class; |
| #if VALGRIND_LEVEL > 0 |
| R_size_t actual_size = 0; |
| #endif |
| |
| /* Handle some scalars directly to improve speed. */ |
| if (length == 1) { |
| switch(type) { |
| case REALSXP: |
| case INTSXP: |
| case LGLSXP: |
| node_class = 1; |
| alloc_size = NodeClassSize[1]; |
| if (FORCE_GC || NO_FREE_NODES() || VHEAP_FREE() < alloc_size) { |
| R_gc_internal(alloc_size); |
| if (NO_FREE_NODES()) |
| mem_err_cons(); |
| if (VHEAP_FREE() < alloc_size) |
| mem_err_heap(size); |
| } |
| |
| CLASS_GET_FREE_NODE(node_class, s); |
| #if VALGRIND_LEVEL > 1 |
| switch(type) { |
| case REALSXP: actual_size = sizeof(double); break; |
| case INTSXP: actual_size = sizeof(int); break; |
| case LGLSXP: actual_size = sizeof(int); break; |
| } |
| VALGRIND_MAKE_MEM_UNDEFINED(STDVEC_DATAPTR(s), actual_size); |
| #endif |
| s->sxpinfo = UnmarkedNodeTemplate.sxpinfo; |
| SETSCALAR(s, 1); |
| SET_NODE_CLASS(s, node_class); |
| R_SmallVallocSize += alloc_size; |
| /* Note that we do not include the header size into VallocSize, |
| but it is counted into memory usage via R_NodesInUse. */ |
| ATTRIB(s) = R_NilValue; |
| SET_TYPEOF(s, type); |
| SET_STDVEC_LENGTH(s, (R_len_t) length); // is 1 |
| SET_STDVEC_TRUELENGTH(s, 0); |
| SET_NAMED(s, 0); |
| INIT_REFCNT(s); |
| return(s); |
| } |
| } |
| |
| if (length > R_XLEN_T_MAX) |
| error(_("vector is too large")); /**** put length into message */ |
| else if (length < 0 ) |
| error(_("negative length vectors are not allowed")); |
| /* number of vector cells to allocate */ |
| switch (type) { |
| case NILSXP: |
| return R_NilValue; |
| case RAWSXP: |
| size = BYTE2VEC(length); |
| #if VALGRIND_LEVEL > 0 |
| actual_size = length; |
| #endif |
| break; |
| case CHARSXP: |
| error("use of allocVector(CHARSXP ...) is defunct\n"); |
| case intCHARSXP: |
| type = CHARSXP; |
| size = BYTE2VEC(length + 1); |
| #if VALGRIND_LEVEL > 0 |
| actual_size = length + 1; |
| #endif |
| break; |
| case LGLSXP: |
| case INTSXP: |
| if (length <= 0) |
| size = 0; |
| else { |
| if (length > R_SIZE_T_MAX / sizeof(int)) |
| error(_("cannot allocate vector of length %d"), length); |
| size = INT2VEC(length); |
| #if VALGRIND_LEVEL > 0 |
| actual_size = length*sizeof(int); |
| #endif |
| } |
| break; |
| case REALSXP: |
| if (length <= 0) |
| size = 0; |
| else { |
| if (length > R_SIZE_T_MAX / sizeof(double)) |
| error(_("cannot allocate vector of length %d"), length); |
| size = FLOAT2VEC(length); |
| #if VALGRIND_LEVEL > 0 |
| actual_size = length * sizeof(double); |
| #endif |
| } |
| break; |
| case CPLXSXP: |
| if (length <= 0) |
| size = 0; |
| else { |
| if (length > R_SIZE_T_MAX / sizeof(Rcomplex)) |
| error(_("cannot allocate vector of length %d"), length); |
| size = COMPLEX2VEC(length); |
| #if VALGRIND_LEVEL > 0 |
| actual_size = length * sizeof(Rcomplex); |
| #endif |
| } |
| break; |
| case STRSXP: |
| case EXPRSXP: |
| case VECSXP: |
| if (length <= 0) |
| size = 0; |
| else { |
| if (length > R_SIZE_T_MAX / sizeof(SEXP)) |
| error(_("cannot allocate vector of length %d"), length); |
| size = PTR2VEC(length); |
| #if VALGRIND_LEVEL > 0 |
| actual_size = length * sizeof(SEXP); |
| #endif |
| } |
| break; |
| case LANGSXP: |
| if(length == 0) return R_NilValue; |
| #ifdef LONG_VECTOR_SUPPORT |
| if (length > R_SHORT_LEN_MAX) error("invalid length for pairlist"); |
| #endif |
| s = allocList((int) length); |
| SET_TYPEOF(s, LANGSXP); |
| return s; |
| case LISTSXP: |
| #ifdef LONG_VECTOR_SUPPORT |
| if (length > R_SHORT_LEN_MAX) error("invalid length for pairlist"); |
| #endif |
| return allocList((int) length); |
| default: |
| error(_("invalid type/length (%s/%d) in vector allocation"), |
| type2char(type), length); |
| } |
| |
| if (allocator) { |
| node_class = CUSTOM_NODE_CLASS; |
| alloc_size = size; |
| } else { |
| if (size <= NodeClassSize[1]) { |
| node_class = 1; |
| alloc_size = NodeClassSize[1]; |
| } |
| else { |
| node_class = LARGE_NODE_CLASS; |
| alloc_size = size; |
| for (int i = 2; i < NUM_SMALL_NODE_CLASSES; i++) { |
| if (size <= NodeClassSize[i]) { |
| node_class = i; |
| alloc_size = NodeClassSize[i]; |
| break; |
| } |
| } |
| } |
| } |
| |
| /* save current R_VSize to roll back adjustment if malloc fails */ |
| old_R_VSize = R_VSize; |
| |
| /* we need to do the gc here so allocSExp doesn't! */ |
| if (FORCE_GC || NO_FREE_NODES() || VHEAP_FREE() < alloc_size) { |
| R_gc_internal(alloc_size); |
| if (NO_FREE_NODES()) |
| mem_err_cons(); |
| if (VHEAP_FREE() < alloc_size) |
| mem_err_heap(size); |
| } |
| |
| if (size > 0) { |
| if (node_class < NUM_SMALL_NODE_CLASSES) { |
| CLASS_GET_FREE_NODE(node_class, s); |
| #if VALGRIND_LEVEL > 1 |
| VALGRIND_MAKE_MEM_UNDEFINED(STDVEC_DATAPTR(s), actual_size); |
| #endif |
| s->sxpinfo = UnmarkedNodeTemplate.sxpinfo; |
| INIT_REFCNT(s); |
| SET_NODE_CLASS(s, node_class); |
| R_SmallVallocSize += alloc_size; |
| SET_STDVEC_LENGTH(s, (R_len_t) length); |
| } |
| else { |
| Rboolean success = FALSE; |
| R_size_t hdrsize = sizeof(SEXPREC_ALIGN); |
| void *mem = NULL; /* initialize to suppress warning */ |
| if (size < (R_SIZE_T_MAX / sizeof(VECREC)) - hdrsize) { /*** not sure this test is quite right -- why subtract the header? LT */ |
| /* I think subtracting the header is fine, "size" (*VSize) |
| variables do not count the header, but the header is |
| included into memory usage via NodesInUse, instead. |
| We want the whole object including the header to be |
| indexable by size_t. - TK */ |
| mem = allocator ? |
| custom_node_alloc(allocator, hdrsize + size * sizeof(VECREC)) : |
| malloc(hdrsize + size * sizeof(VECREC)); |
| if (mem == NULL) { |
| /* If we are near the address space limit, we |
| might be short of address space. So return |
| all unused objects to malloc and try again. */ |
| R_gc_no_finalizers(alloc_size); |
| mem = allocator ? |
| custom_node_alloc(allocator, hdrsize + size * sizeof(VECREC)) : |
| malloc(hdrsize + size * sizeof(VECREC)); |
| } |
| if (mem != NULL) { |
| s = mem; |
| SET_STDVEC_LENGTH(s, length); |
| success = TRUE; |
| } |
| else s = NULL; |
| #ifdef R_MEMORY_PROFILING |
| R_ReportAllocation(hdrsize + size * sizeof(VECREC)); |
| #endif |
| } else s = NULL; /* suppress warning */ |
| if (! success) { |
| double dsize = (double)size * sizeof(VECREC)/1024.0; |
| /* reset the vector heap limit */ |
| R_VSize = old_R_VSize; |
| if(dsize > 1024.0*1024.0) |
| errorcall(R_NilValue, |
| _("cannot allocate vector of size %0.1f Gb"), |
| dsize/1024.0/1024.0); |
| if(dsize > 1024.0) |
| errorcall(R_NilValue, |
| _("cannot allocate vector of size %0.1f Mb"), |
| dsize/1024.0); |
| else |
| errorcall(R_NilValue, |
| _("cannot allocate vector of size %0.f Kb"), |
| dsize); |
| } |
| s->sxpinfo = UnmarkedNodeTemplate.sxpinfo; |
| INIT_REFCNT(s); |
| SET_NODE_CLASS(s, node_class); |
| if (!allocator) R_LargeVallocSize += size; |
| R_GenHeap[node_class].AllocCount++; |
| R_NodesInUse++; |
| SNAP_NODE(s, R_GenHeap[node_class].New); |
| } |
| ATTRIB(s) = R_NilValue; |
| SET_TYPEOF(s, type); |
| } |
| else { |
| GC_PROT(s = allocSExpNonCons(type)); |
| SET_STDVEC_LENGTH(s, (R_len_t) length); |
| } |
| SETALTREP(s, 0); |
| SET_STDVEC_TRUELENGTH(s, 0); |
| SET_NAMED(s, 0); |
| INIT_REFCNT(s); |
| |
| /* The following prevents disaster in the case */ |
| /* that an uninitialised string vector is marked */ |
| /* Direct assignment is OK since the node was just allocated and */ |
| /* so is at least as new as R_NilValue and R_BlankString */ |
| if (type == EXPRSXP || type == VECSXP) { |
| SEXP *data = STRING_PTR(s); |
| #if VALGRIND_LEVEL > 1 |
| VALGRIND_MAKE_MEM_DEFINED(STRING_PTR(s), actual_size); |
| #endif |
| for (R_xlen_t i = 0; i < length; i++) |
| data[i] = R_NilValue; |
| } |
| else if(type == STRSXP) { |
| SEXP *data = STRING_PTR(s); |
| #if VALGRIND_LEVEL > 1 |
| VALGRIND_MAKE_MEM_DEFINED(STRING_PTR(s), actual_size); |
| #endif |
| for (R_xlen_t i = 0; i < length; i++) |
| data[i] = R_BlankString; |
| } |
| else if (type == CHARSXP || type == intCHARSXP) { |
| #if VALGRIND_LEVEL > 0 |
| VALGRIND_MAKE_MEM_UNDEFINED(CHAR(s), actual_size); |
| #endif |
| CHAR_RW(s)[length] = 0; |
| } |
| #if VALGRIND_LEVEL > 0 |
| else if (type == REALSXP) |
| VALGRIND_MAKE_MEM_UNDEFINED(REAL(s), actual_size); |
| else if (type == INTSXP) |
| VALGRIND_MAKE_MEM_UNDEFINED(INTEGER(s), actual_size); |
| else if (type == LGLSXP) |
| VALGRIND_MAKE_MEM_UNDEFINED(LOGICAL(s), actual_size); |
| else if (type == CPLXSXP) |
| VALGRIND_MAKE_MEM_UNDEFINED(COMPLEX(s), actual_size); |
| else if (type == RAWSXP) |
| VALGRIND_MAKE_MEM_UNDEFINED(RAW(s), actual_size); |
| #endif |
| return s; |
| } |
| |
| /* For future hiding of allocVector(CHARSXP) */ |
| SEXP attribute_hidden allocCharsxp(R_len_t len) |
| { |
| return allocVector(intCHARSXP, len); |
| } |
| |
| SEXP allocList(int n) |
| { |
| int i; |
| SEXP result; |
| result = R_NilValue; |
| for (i = 0; i < n; i++) |
| result = CONS(R_NilValue, result); |
| return result; |
| } |
| |
| SEXP allocS4Object(void) |
| { |
| SEXP s; |
| GC_PROT(s = allocSExpNonCons(S4SXP)); |
| SET_S4_OBJECT(s); |
| return s; |
| } |
| |
| static SEXP allocFormalsList(int nargs, ...) |
| { |
| SEXP res = R_NilValue; |
| SEXP n; |
| int i; |
| va_list(syms); |
| va_start(syms, nargs); |
| |
| for(i = 0; i < nargs; i++) { |
| res = CONS(R_NilValue, res); |
| } |
| R_PreserveObject(res); |
| |
| n = res; |
| for(i = 0; i < nargs; i++) { |
| SET_TAG(n, (SEXP) va_arg(syms, SEXP)); |
| MARK_NOT_MUTABLE(n); |
| n = CDR(n); |
| } |
| va_end(syms); |
| |
| return res; |
| } |
| |
| |
| SEXP allocFormalsList2(SEXP sym1, SEXP sym2) |
| { |
| return allocFormalsList(2, sym1, sym2); |
| } |
| |
| SEXP allocFormalsList3(SEXP sym1, SEXP sym2, SEXP sym3) |
| { |
| return allocFormalsList(3, sym1, sym2, sym3); |
| } |
| |
| SEXP allocFormalsList4(SEXP sym1, SEXP sym2, SEXP sym3, SEXP sym4) |
| { |
| return allocFormalsList(4, sym1, sym2, sym3, sym4); |
| } |
| |
| SEXP allocFormalsList5(SEXP sym1, SEXP sym2, SEXP sym3, SEXP sym4, SEXP sym5) |
| { |
| return allocFormalsList(5, sym1, sym2, sym3, sym4, sym5); |
| } |
| |
| SEXP allocFormalsList6(SEXP sym1, SEXP sym2, SEXP sym3, SEXP sym4, |
| SEXP sym5, SEXP sym6) |
| { |
| return allocFormalsList(6, sym1, sym2, sym3, sym4, sym5, sym6); |
| } |
| |
| /* "gc" a mark-sweep or in-place generational garbage collector */ |
| |
| void R_gc(void) |
| { |
| num_old_gens_to_collect = NUM_OLD_GENERATIONS; |
| R_gc_internal(0); |
| #ifndef IMMEDIATE_FINALIZERS |
| R_RunPendingFinalizers(); |
| #endif |
| } |
| |
| void R_gc_lite(void) |
| { |
| R_gc_internal(0); |
| #ifndef IMMEDIATE_FINALIZERS |
| R_RunPendingFinalizers(); |
| #endif |
| } |
| |
| static void R_gc_no_finalizers(R_size_t size_needed) |
| { |
| num_old_gens_to_collect = NUM_OLD_GENERATIONS; |
| R_gc_internal(size_needed); |
| } |
| |
| static double gctimes[5], gcstarttimes[5]; |
| static Rboolean gctime_enabled = FALSE; |
| |
| /* this is primitive */ |
| SEXP attribute_hidden do_gctime(SEXP call, SEXP op, SEXP args, SEXP env) |
| { |
| SEXP ans; |
| |
| if (args == R_NilValue) |
| gctime_enabled = TRUE; |
| else { |
| check1arg(args, call, "on"); |
| gctime_enabled = asLogical(CAR(args)); |
| } |
| ans = allocVector(REALSXP, 5); |
| REAL(ans)[0] = gctimes[0]; |
| REAL(ans)[1] = gctimes[1]; |
| REAL(ans)[2] = gctimes[2]; |
| REAL(ans)[3] = gctimes[3]; |
| REAL(ans)[4] = gctimes[4]; |
| return ans; |
| } |
| |
| static void gc_start_timing(void) |
| { |
| if (gctime_enabled) |
| R_getProcTime(gcstarttimes); |
| } |
| |
| static void gc_end_timing(void) |
| { |
| if (gctime_enabled) { |
| double times[5], delta; |
| R_getProcTime(times); |
| |
| /* add delta to compensate for timer resolution */ |
| #if 0 |
| /* this seems to over-compensate too */ |
| delta = R_getClockIncrement(); |
| #else |
| delta = 0; |
| #endif |
| |
| gctimes[0] += times[0] - gcstarttimes[0] + delta; |
| gctimes[1] += times[1] - gcstarttimes[1] + delta; |
| gctimes[2] += times[2] - gcstarttimes[2]; |
| gctimes[3] += times[3] - gcstarttimes[3]; |
| gctimes[4] += times[4] - gcstarttimes[4]; |
| } |
| } |
| |
| #define R_MAX(a,b) (a) < (b) ? (b) : (a) |
| |
| #ifdef THREADCHECK |
| # if !defined(Win32) && defined(HAVE_PTHREAD) |
| # include <pthread.h> |
| void attribute_hidden R_check_thread(const char *s) |
| { |
| static Rboolean main_thread_inited = FALSE; |
| static pthread_t main_thread; |
| if (! main_thread_inited) { |
| main_thread = pthread_self(); |
| main_thread_inited = TRUE; |
| } |
| if (! pthread_equal(main_thread, pthread_self())) { |
| char buf[1024]; |
| size_t bsize = sizeof buf; |
| memset(buf, 0, bsize); |
| snprintf(buf, bsize - 1, "Wrong thread calling '%s'", s); |
| R_Suicide(buf); |
| } |
| } |
| # else |
| /* This could be implemented for Windows using their threading API */ |
| void attribute_hidden R_check_thread(const char *s) {} |
| # endif |
| #endif |
| |
| static void R_gc_internal(R_size_t size_needed) |
| { |
| R_CHECK_THREAD; |
| if (!R_GCEnabled) { |
| if (NO_FREE_NODES()) |
| R_NSize = R_NodesInUse + 1; |
| |
| if (num_old_gens_to_collect < NUM_OLD_GENERATIONS && |
| VHEAP_FREE() < size_needed + R_MinFreeFrac * R_VSize) |
| num_old_gens_to_collect++; |
| |
| if (size_needed > VHEAP_FREE()) |
| R_VSize += size_needed - VHEAP_FREE(); |
| |
| gc_pending = TRUE; |
| return; |
| } |
| gc_pending = FALSE; |
| |
| R_size_t onsize = R_NSize /* can change during collection */; |
| double ncells, vcells, vfrac, nfrac; |
| SEXPTYPE first_bad_sexp_type = 0; |
| #ifdef PROTECTCHECK |
| SEXPTYPE first_bad_sexp_type_old_type = 0; |
| #endif |
| SEXP first_bad_sexp_type_sexp = NULL; |
| int first_bad_sexp_type_line = 0; |
| int gens_collected = 0; |
| |
| #ifdef IMMEDIATE_FINALIZERS |
| Rboolean first = TRUE; |
| again: |
| #endif |
| |
| gc_count++; |
| |
| R_N_maxused = R_MAX(R_N_maxused, R_NodesInUse); |
| R_V_maxused = R_MAX(R_V_maxused, R_VSize - VHEAP_FREE()); |
| |
| BEGIN_SUSPEND_INTERRUPTS { |
| R_in_gc = TRUE; |
| gc_start_timing(); |
| gens_collected = RunGenCollect(size_needed); |
| gc_end_timing(); |
| R_in_gc = FALSE; |
| } END_SUSPEND_INTERRUPTS; |
| |
| if (R_check_constants > 2 || |
| (R_check_constants > 1 && gens_collected == NUM_OLD_GENERATIONS)) |
| R_checkConstants(TRUE); |
| |
| if (bad_sexp_type_seen != 0 && first_bad_sexp_type == 0) { |
| first_bad_sexp_type = bad_sexp_type_seen; |
| #ifdef PROTECTCHECK |
| first_bad_sexp_type_old_type = bad_sexp_type_old_type; |
| #endif |
| first_bad_sexp_type_sexp = bad_sexp_type_sexp; |
| first_bad_sexp_type_line = bad_sexp_type_line; |
| } |
| |
| if (gc_reporting) { |
| ncells = onsize - R_Collected; |
| nfrac = (100.0 * ncells) / R_NSize; |
| /* We try to make this consistent with the results returned by gc */ |
| ncells = 0.1*ceil(10*ncells * sizeof(SEXPREC)/Mega); |
| REprintf("\n%.1f Mbytes of cons cells used (%d%%)\n", |
| ncells, (int) (nfrac + 0.5)); |
| vcells = R_VSize - VHEAP_FREE(); |
| vfrac = (100.0 * vcells) / R_VSize; |
| vcells = 0.1*ceil(10*vcells * vsfac/Mega); |
| REprintf("%.1f Mbytes of vectors used (%d%%)\n", |
| vcells, (int) (vfrac + 0.5)); |
| } |
| |
| #ifdef IMMEDIATE_FINALIZERS |
| if (first) { |
| first = FALSE; |
| /* Run any eligible finalizers. The return result of |
| RunFinalizers is TRUE if any finalizers are actually run. |
| There is a small chance that running finalizers here may |
| chew up enough memory to make another immediate collection |
| necessary. If so, we jump back to the beginning and run |
| the collection, but on this second pass we do not run |
| finalizers. */ |
| if (RunFinalizers() && |
| (NO_FREE_NODES() || size_needed > VHEAP_FREE())) |
| goto again; |
| } |
| #endif |
| |
| if (first_bad_sexp_type != 0) { |
| #ifdef PROTECTCHECK |
| if (first_bad_sexp_type == FREESXP) |
| error("GC encountered a node (%p) with type FREESXP (was %s)" |
| " at memory.c:%d", |
| first_bad_sexp_type_sexp, |
| sexptype2char(first_bad_sexp_type_old_type), |
| first_bad_sexp_type_line); |
| else |
| error("GC encountered a node (%p) with an unknown SEXP type: %d" |
| " at memory.c:%d", |
| first_bad_sexp_type_sexp, |
| first_bad_sexp_type, |
| first_bad_sexp_type_line); |
| #else |
| error("GC encountered a node (%p) with an unknown SEXP type: %d" |
| " at memory.c:%d", |
| first_bad_sexp_type_sexp, |
| first_bad_sexp_type, |
| first_bad_sexp_type_line); |
| #endif |
| } |
| |
| /* sanity check on logical scalar values */ |
| if (R_TrueValue != NULL && LOGICAL(R_TrueValue)[0] != TRUE) { |
| LOGICAL(R_TrueValue)[0] = TRUE; |
| error("internal TRUE value has been modified"); |
| } |
| if (R_FalseValue != NULL && LOGICAL(R_FalseValue)[0] != FALSE) { |
| LOGICAL(R_FalseValue)[0] = FALSE; |
| error("internal FALSE value has been modified"); |
| } |
| if (R_LogicalNAValue != NULL && |
| LOGICAL(R_LogicalNAValue)[0] != NA_LOGICAL) { |
| LOGICAL(R_LogicalNAValue)[0] = NA_LOGICAL; |
| error("internal logical NA value has been modified"); |
| } |
| } |
| |
| |
| SEXP attribute_hidden do_memoryprofile(SEXP call, SEXP op, SEXP args, SEXP env) |
| { |
| SEXP ans, nms; |
| int i, tmp; |
| |
| checkArity(op, args); |
| PROTECT(ans = allocVector(INTSXP, 24)); |
| PROTECT(nms = allocVector(STRSXP, 24)); |
| for (i = 0; i < 24; i++) { |
| INTEGER(ans)[i] = 0; |
| SET_STRING_ELT(nms, i, type2str(i > LGLSXP? i+2 : i)); |
| } |
| setAttrib(ans, R_NamesSymbol, nms); |
| |
| BEGIN_SUSPEND_INTERRUPTS { |
| int gen; |
| |
| /* run a full GC to make sure that all stuff in use is in Old space */ |
| R_gc(); |
| for (gen = 0; gen < NUM_OLD_GENERATIONS; gen++) { |
| for (i = 0; i < NUM_NODE_CLASSES; i++) { |
| SEXP s; |
| for (s = NEXT_NODE(R_GenHeap[i].Old[gen]); |
| s != R_GenHeap[i].Old[gen]; |
| s = NEXT_NODE(s)) { |
| tmp = TYPEOF(s); |
| if(tmp > LGLSXP) tmp -= 2; |
| INTEGER(ans)[tmp]++; |
| } |
| } |
| } |
| } END_SUSPEND_INTERRUPTS; |
| UNPROTECT(2); |
| return ans; |
| } |
| |
| /* "protect" push a single argument onto R_PPStack */ |
| |
| /* In handling a stack overflow we have to be careful not to use |
| PROTECT. error("protect(): stack overflow") would call deparse1, |
| which uses PROTECT and segfaults.*/ |
| |
| /* However, the traceback creation in the normal error handler also |
| does a PROTECT, as does the jumping code, at least if there are |
| cleanup expressions to handle on the way out. So for the moment |
| we'll allocate a slightly larger PP stack and only enable the added |
| red zone during handling of a stack overflow error. LT */ |
| |
| static void reset_pp_stack(void *data) |
| { |
| int *poldpps = data; |
| R_PPStackSize = *poldpps; |
| } |
| |
| void NORET R_signal_protect_error(void) |
| { |
| RCNTXT cntxt; |
| int oldpps = R_PPStackSize; |
| |
| begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv, |
| R_NilValue, R_NilValue); |
| cntxt.cend = &reset_pp_stack; |
| cntxt.cenddata = &oldpps; |
| |
| if (R_PPStackSize < R_RealPPStackSize) |
| R_PPStackSize = R_RealPPStackSize; |
| errorcall(R_NilValue, _("protect(): protection stack overflow")); |
| |
| endcontext(&cntxt); /* not reached */ |
| } |
| |
| void NORET R_signal_unprotect_error(void) |
| { |
| error(ngettext("unprotect(): only %d protected item", |
| "unprotect(): only %d protected items", R_PPStackTop), |
| R_PPStackTop); |
| } |
| |
| #ifndef INLINE_PROTECT |
| SEXP protect(SEXP s) |
| { |
| R_CHECK_THREAD; |
| if (R_PPStackTop >= R_PPStackSize) |
| R_signal_protect_error(); |
| R_PPStack[R_PPStackTop++] = CHK(s); |
| return s; |
| } |
| |
| |
| /* "unprotect" pop argument list from top of R_PPStack */ |
| |
| void unprotect(int l) |
| { |
| R_CHECK_THREAD; |
| if (R_PPStackTop >= l) |
| R_PPStackTop -= l; |
| else R_signal_unprotect_error(); |
| } |
| #endif |
| |
| /* "unprotect_ptr" remove pointer from somewhere in R_PPStack */ |
| |
| void unprotect_ptr(SEXP s) |
| { |
| R_CHECK_THREAD; |
| int i = R_PPStackTop; |
| |
| /* go look for s in R_PPStack */ |
| /* (should be among the top few items) */ |
| do { |
| if (i == 0) |
| error(_("unprotect_ptr: pointer not found")); |
| } while ( R_PPStack[--i] != s ); |
| |
| /* OK, got it, and i is indexing its location */ |
| /* Now drop stack above it, if any */ |
| |
| while (++i < R_PPStackTop) R_PPStack[i - 1] = R_PPStack[i]; |
| |
| R_PPStackTop--; |
| } |
| |
| /* Debugging function: is s protected? */ |
| |
| int Rf_isProtected(SEXP s) |
| { |
| R_CHECK_THREAD; |
| int i = R_PPStackTop; |
| |
| /* go look for s in R_PPStack */ |
| do { |
| if (i == 0) |
| return(i); |
| } while ( R_PPStack[--i] != s ); |
| |
| /* OK, got it, and i is indexing its location */ |
| return(i); |
| } |
| |
| |
| #ifndef INLINE_PROTECT |
| void R_ProtectWithIndex(SEXP s, PROTECT_INDEX *pi) |
| { |
| protect(s); |
| *pi = R_PPStackTop - 1; |
| } |
| #endif |
| |
| void NORET R_signal_reprotect_error(PROTECT_INDEX i) |
| { |
| error(ngettext("R_Reprotect: only %d protected item, can't reprotect index %d", |
| "R_Reprotect: only %d protected items, can't reprotect index %d", |
| R_PPStackTop), |
| R_PPStackTop, i); |
| } |
| |
| #ifndef INLINE_PROTECT |
| void R_Reprotect(SEXP s, PROTECT_INDEX i) |
| { |
| R_CHECK_THREAD; |
| if (i >= R_PPStackTop || i < 0) |
| R_signal_reprotect_error(i); |
| R_PPStack[i] = s; |
| } |
| #endif |
| |
| #ifdef UNUSED |
| /* remove all objects from the protection stack from index i upwards |
| and return them in a vector. The order in the vector is from new |
| to old. */ |
| SEXP R_CollectFromIndex(PROTECT_INDEX i) |
| { |
| R_CHECK_THREAD; |
| SEXP res; |
| int top = R_PPStackTop, j = 0; |
| if (i > top) i = top; |
| res = protect(allocVector(VECSXP, top - i)); |
| while (i < top) |
| SET_VECTOR_ELT(res, j++, R_PPStack[--top]); |
| R_PPStackTop = top; /* this includes the protect we used above */ |
| return res; |
| } |
| #endif |
| |
| /* "initStack" initialize environment stack */ |
| attribute_hidden |
| void initStack(void) |
| { |
| R_PPStackTop = 0; |
| } |
| |
| |
| /* S-like wrappers for calloc, realloc and free that check for error |
| conditions */ |
| |
| void *R_chk_calloc(size_t nelem, size_t elsize) |
| { |
| void *p; |
| #ifndef HAVE_WORKING_CALLOC |
| if(nelem == 0) |
| return(NULL); |
| #endif |
| p = calloc(nelem, elsize); |
| if(!p) /* problem here is that we don't have a format for size_t. */ |
| error(_("'Calloc' could not allocate memory (%.0f of %u bytes)"), |
| (double) nelem, elsize); |
| return(p); |
| } |
| |
| void *R_chk_realloc(void *ptr, size_t size) |
| { |
| void *p; |
| /* Protect against broken realloc */ |
| if(ptr) p = realloc(ptr, size); else p = malloc(size); |
| if(!p) |
| error(_("'Realloc' could not re-allocate memory (%.0f bytes)"), |
| (double) size); |
| return(p); |
| } |
| |
| void R_chk_free(void *ptr) |
| { |
| /* S-PLUS warns here, but there seems no reason to do so */ |
| /* if(!ptr) warning("attempt to free NULL pointer by Free"); */ |
| if(ptr) free(ptr); /* ANSI C says free has no effect on NULL, but |
| better to be safe here */ |
| } |
| |
| /* This code keeps a list of objects which are not assigned to variables |
| but which are required to persist across garbage collections. The |
| objects are registered with R_PreserveObject and deregistered with |
| R_ReleaseObject. */ |
| |
| void R_PreserveObject(SEXP object) |
| { |
| R_CHECK_THREAD; |
| R_PreciousList = CONS(object, R_PreciousList); |
| } |
| |
| static SEXP RecursiveRelease(SEXP object, SEXP list) |
| { |
| if (!isNull(list)) { |
| if (object == CAR(list)) |
| return CDR(list); |
| else |
| CDR(list) = RecursiveRelease(object, CDR(list)); |
| } |
| return list; |
| } |
| |
| void R_ReleaseObject(SEXP object) |
| { |
| R_CHECK_THREAD; |
| R_PreciousList = RecursiveRelease(object, R_PreciousList); |
| } |
| |
| /* This code is similar to R_PreserveObject/R_ReleasObject, but objects are |
| kept in a provided multi-set (which needs to be itself protected). |
| When protected via PROTECT, the multi-set is automatically unprotected |
| during long jump, and thus all its members are eventually reclaimed. |
| These functions were introduced for parsers generated by bison, because |
| one cannot instruct bison to use PROTECT/UNPROTECT when working with |
| the stack of semantic values. */ |
| |
| /* Multi-set is defined by a triple (store, npreserved, initialSize) |
| npreserved is the number of elements in the store (counting each instance |
| of the same value) |
| store is a VECSXP or R_NilValue |
| when VECSXP, preserved values are stored at the beginning, filled up by |
| R_NilValue |
| initialSize is the size for the VECSXP to be allocated if preserving values |
| while store is R_NilValue |
| |
| The representation is CONS(store, npreserved) with TAG()==initialSize |
| */ |
| |
| /* Create new multi-set for protecting objects. initialSize may be zero |
| (a hardcoded default is then used). */ |
| SEXP R_NewPreciousMSet(int initialSize) |
| { |
| SEXP npreserved, mset, isize; |
| |
| /* npreserved is modified in place */ |
| npreserved = allocVector(INTSXP, 1); |
| SET_INTEGER_ELT(npreserved, 0, 0); |
| PROTECT(mset = CONS(R_NilValue, npreserved)); |
| /* isize is not modified in place */ |
| if (initialSize < 0) |
| error("'initialSize' must be non-negative"); |
| isize = ScalarInteger(initialSize); |
| SET_TAG(mset, isize); |
| UNPROTECT(1); /* mset */ |
| return mset; |
| } |
| |
| static void checkMSet(SEXP mset) |
| { |
| SEXP store = CAR(mset); |
| SEXP npreserved = CDR(mset); |
| SEXP isize = TAG(mset); |
| if (/*MAYBE_REFERENCED(mset) ||*/ |
| ((store != R_NilValue) && |
| (TYPEOF(store) != VECSXP /*|| MAYBE_REFERENCED(store)*/)) || |
| (TYPEOF(npreserved) != INTSXP || XLENGTH(npreserved) != 1 /*|| |
| MAYBE_REFERENCED(npreserved)*/) || |
| (TYPEOF(isize) != INTSXP || XLENGTH(isize) != 1)) |
| |
| error("Invalid mset"); |
| } |
| |
| /* Add object to multi-set. The object will be protected as long as the |
| multi-set is protected. */ |
| void R_PreserveInMSet(SEXP x, SEXP mset) |
| { |
| if (x == R_NilValue || isSymbol(x)) |
| return; /* no need to preserve */ |
| PROTECT(x); |
| checkMSet(mset); |
| SEXP store = CAR(mset); |
| int *n = INTEGER(CDR(mset)); |
| if (store == R_NilValue) { |
| R_xlen_t newsize = INTEGER_ELT(TAG(mset), 0); |
| if (newsize == 0) |
| newsize = 4; /* default minimum size */ |
| store = allocVector(VECSXP, newsize); |
| SETCAR(mset, store); |
| } |
| R_xlen_t size = XLENGTH(store); |
| if (*n == size) { |
| R_xlen_t newsize = 2 * size; |
| if (newsize >= INT_MAX || newsize < size) |
| error("Multi-set overflow"); |
| SEXP newstore = PROTECT(allocVector(VECSXP, newsize)); |
| for(R_xlen_t i = 0; i < size; i++) |
| SET_VECTOR_ELT(newstore, i, VECTOR_ELT(store, i)); |
| SETCAR(mset, newstore); |
| UNPROTECT(1); /* newstore */ |
| store = newstore; |
| } |
| UNPROTECT(1); /* x */ |
| SET_VECTOR_ELT(store, (*n)++, x); |
| } |
| |
| /* Remove (one instance of) the object from the multi-set. If there is another |
| instance of the object in the multi-set, it will still be protected. If there |
| is no instance of the object, the function does nothing. */ |
| void R_ReleaseFromMSet(SEXP x, SEXP mset) |
| { |
| if (x == R_NilValue || isSymbol(x)) |
| return; /* not preserved */ |
| checkMSet(mset); |
| SEXP store = CAR(mset); |
| if (store == R_NilValue) |
| return; /* not preserved */ |
| int *n = INTEGER(CDR(mset)); |
| for(R_xlen_t i = (*n) - 1; i >= 0; i--) { |
| if (VECTOR_ELT(store, i) == x) { |
| for(;i < (*n) - 1; i++) |
| SET_VECTOR_ELT(store, i, VECTOR_ELT(store, i + 1)); |
| SET_VECTOR_ELT(store, i, R_NilValue); |
| (*n)--; |
| return; |
| } |
| } |
| /* not preserved */ |
| } |
| |
| /* Release all objects from the multi-set, but the multi-set can be used for |
| preserving more objects. */ |
| void R_ReleaseMSet(SEXP mset, int keepSize) |
| { |
| checkMSet(mset); |
| SEXP store = CAR(mset); |
| if (store == R_NilValue) |
| return; /* already empty */ |
| int *n = INTEGER(CDR(mset)); |
| if (XLENGTH(store) <= keepSize) { |
| /* just free the entries */ |
| for(R_xlen_t i = 0; i < *n; i++) |
| SET_VECTOR_ELT(store, i, R_NilValue); |
| } else |
| SETCAR(mset, R_NilValue); |
| *n = 0; |
| } |
| |
| /* External Pointer Objects */ |
| SEXP R_MakeExternalPtr(void *p, SEXP tag, SEXP prot) |
| { |
| SEXP s = allocSExp(EXTPTRSXP); |
| EXTPTR_PTR(s) = p; |
| EXTPTR_PROT(s) = CHK(prot); |
| EXTPTR_TAG(s) = CHK(tag); |
| return s; |
| } |
| |
| void *R_ExternalPtrAddr(SEXP s) |
| { |
| return EXTPTR_PTR(CHK(s)); |
| } |
| |
| SEXP R_ExternalPtrTag(SEXP s) |
| { |
| return CHK(EXTPTR_TAG(CHK(s))); |
| } |
| |
| SEXP R_ExternalPtrProtected(SEXP s) |
| { |
| return CHK(EXTPTR_PROT(CHK(s))); |
| } |
| |
| void R_ClearExternalPtr(SEXP s) |
| { |
| EXTPTR_PTR(s) = NULL; |
| } |
| |
| void R_SetExternalPtrAddr(SEXP s, void *p) |
| { |
| EXTPTR_PTR(s) = p; |
| } |
| |
| void R_SetExternalPtrTag(SEXP s, SEXP tag) |
| { |
| FIX_REFCNT(s, EXTPTR_TAG(s), tag); |
| CHECK_OLD_TO_NEW(s, tag); |
| EXTPTR_TAG(s) = tag; |
| } |
| |
| void R_SetExternalPtrProtected(SEXP s, SEXP p) |
| { |
| FIX_REFCNT(s, EXTPTR_PROT(s), p); |
| CHECK_OLD_TO_NEW(s, p); |
| EXTPTR_PROT(s) = p; |
| } |
| |
| /* |
| Added to API in R 3.4.0. |
| Work around casting issues: works where it is needed. |
| */ |
| typedef union {void *p; DL_FUNC fn;} fn_ptr; |
| |
| SEXP R_MakeExternalPtrFn(DL_FUNC p, SEXP tag, SEXP prot) |
| { |
| fn_ptr tmp; |
| SEXP s = allocSExp(EXTPTRSXP); |
| tmp.fn = p; |
| EXTPTR_PTR(s) = tmp.p; |
| EXTPTR_PROT(s) = CHK(prot); |
| EXTPTR_TAG(s) = CHK(tag); |
| return s; |
| } |
| |
| DL_FUNC R_ExternalPtrAddrFn(SEXP s) |
| { |
| fn_ptr tmp; |
| tmp.p = EXTPTR_PTR(CHK(s)); |
| return tmp.fn; |
| } |
| |
| |
| |
| /* The following functions are replacements for the accessor macros. |
| They are used by code that does not have direct access to the |
| internal representation of objects. The replacement functions |
| implement the write barrier. */ |
| |
| /* General Cons Cell Attributes */ |
| SEXP (ATTRIB)(SEXP x) { return CHK(ATTRIB(CHK(x))); } |
| int (OBJECT)(SEXP x) { return OBJECT(CHK(x)); } |
| int (MARK)(SEXP x) { return MARK(CHK(x)); } |
| int (TYPEOF)(SEXP x) { return TYPEOF(CHK(x)); } |
| int (NAMED)(SEXP x) { return NAMED(CHK(x)); } |
| int (RTRACE)(SEXP x) { return RTRACE(CHK(x)); } |
| int (LEVELS)(SEXP x) { return LEVELS(CHK(x)); } |
| int (REFCNT)(SEXP x) { return REFCNT(CHK(x)); } |
| int (TRACKREFS)(SEXP x) { return TRACKREFS(CHK(x)); } |
| int (ALTREP)(SEXP x) { return ALTREP(CHK(x)); } |
| int (IS_SCALAR)(SEXP x, int type) { return IS_SCALAR(CHK(x), type); } |
| void (DECREMENT_REFCNT)(SEXP x) { DECREMENT_REFCNT(CHK(x)); } |
| void (INCREMENT_REFCNT)(SEXP x) { INCREMENT_REFCNT(CHK(x)); } |
| void (DISABLE_REFCNT)(SEXP x) { DISABLE_REFCNT(CHK(x)); } |
| void (ENABLE_REFCNT)(SEXP x) { ENABLE_REFCNT(CHK(x)); } |
| void (MARK_NOT_MUTABLE)(SEXP x) { MARK_NOT_MUTABLE(CHK(x)); } |
| |
| void (SET_ATTRIB)(SEXP x, SEXP v) { |
| if(TYPEOF(v) != LISTSXP && TYPEOF(v) != NILSXP) |
| error("value of 'SET_ATTRIB' must be a pairlist or NULL, not a '%s'", |
| type2char(TYPEOF(v))); |
| FIX_REFCNT(x, ATTRIB(x), v); |
| CHECK_OLD_TO_NEW(x, v); |
| ATTRIB(x) = v; |
| } |
| void (SET_OBJECT)(SEXP x, int v) { SET_OBJECT(CHK(x), v); } |
| void (SET_TYPEOF)(SEXP x, int v) { SET_TYPEOF(CHK(x), v); } |
| void (SET_NAMED)(SEXP x, int v) { SET_NAMED(CHK(x), v); } |
| void (SET_RTRACE)(SEXP x, int v) { SET_RTRACE(CHK(x), v); } |
| int (SETLEVELS)(SEXP x, int v) { return SETLEVELS(CHK(x), v); } |
| void DUPLICATE_ATTRIB(SEXP to, SEXP from) { |
| SET_ATTRIB(CHK(to), duplicate(CHK(ATTRIB(CHK(from))))); |
| SET_OBJECT(CHK(to), OBJECT(from)); |
| IS_S4_OBJECT(from) ? SET_S4_OBJECT(to) : UNSET_S4_OBJECT(to); |
| } |
| void SHALLOW_DUPLICATE_ATTRIB(SEXP to, SEXP from) { |
| SET_ATTRIB(CHK(to), shallow_duplicate(CHK(ATTRIB(CHK(from))))); |
| SET_OBJECT(CHK(to), OBJECT(from)); |
| IS_S4_OBJECT(from) ? SET_S4_OBJECT(to) : UNSET_S4_OBJECT(to); |
| } |
| |
| void (ENSURE_NAMEDMAX)(SEXP x) { ENSURE_NAMEDMAX(CHK(x)); } |
| void (ENSURE_NAMED)(SEXP x) { ENSURE_NAMED(CHK(x)); } |
| void (SETTER_CLEAR_NAMED)(SEXP x) { SETTER_CLEAR_NAMED(CHK(x)); } |
| void (RAISE_NAMED)(SEXP x, int n) { RAISE_NAMED(CHK(x), n); } |
| |
| /* S4 object testing */ |
| int (IS_S4_OBJECT)(SEXP x){ return IS_S4_OBJECT(CHK(x)); } |
| void (SET_S4_OBJECT)(SEXP x){ SET_S4_OBJECT(CHK(x)); } |
| void (UNSET_S4_OBJECT)(SEXP x){ UNSET_S4_OBJECT(CHK(x)); } |
| |
| /* JIT optimization support */ |
| int (NOJIT)(SEXP x) { return NOJIT(CHK(x)); } |
| int (MAYBEJIT)(SEXP x) { return MAYBEJIT(CHK(x)); } |
| void (SET_NOJIT)(SEXP x) { SET_NOJIT(CHK(x)); } |
| void (SET_MAYBEJIT)(SEXP x) { SET_MAYBEJIT(CHK(x)); } |
| void (UNSET_MAYBEJIT)(SEXP x) { UNSET_MAYBEJIT(CHK(x)); } |
| |
| /* Growable vector support */ |
| int (IS_GROWABLE)(SEXP x) { return IS_GROWABLE(CHK(x)); } |
| void (SET_GROWABLE_BIT)(SEXP x) { SET_GROWABLE_BIT(CHK(x)); } |
| |
| static int nvec[32] = { |
| 1,1,1,1,1,1,1,1, |
| 1,0,0,1,1,0,0,0, |
| 0,1,1,0,0,1,1,0, |
| 0,1,1,1,1,1,1,1 |
| }; |
| |
| static R_INLINE SEXP CHK2(SEXP x) |
| { |
| x = CHK(x); |
| if(nvec[TYPEOF(x)]) |
| error("LENGTH or similar applied to %s object", type2char(TYPEOF(x))); |
| return x; |
| } |
| |
| /* Vector Accessors */ |
| int (LENGTH)(SEXP x) { return x == R_NilValue ? 0 : LENGTH(CHK2(x)); } |
| R_xlen_t (XLENGTH)(SEXP x) { return XLENGTH(CHK2(x)); } |
| R_xlen_t (TRUELENGTH)(SEXP x) { return TRUELENGTH(CHK2(x)); } |
| |
| void (SETLENGTH)(SEXP x, R_xlen_t v) |
| { |
| if (ALTREP(x)) |
| error("SETLENGTH() cannot be applied to an ALTVEC object."); |
| if (! isVector(x)) |
| error(_("SETLENGTH() can only be applied to a standard vector, " |
| "not a '%s'"), type2char(TYPEOF(x))); |
| SET_STDVEC_LENGTH(CHK2(x), v); |
| } |
| |
| void (SET_TRUELENGTH)(SEXP x, R_xlen_t v) { SET_TRUELENGTH(CHK2(x), v); } |
| int (IS_LONG_VEC)(SEXP x) { return IS_LONG_VEC(CHK2(x)); } |
| #ifdef TESTING_WRITE_BARRIER |
| R_xlen_t (STDVEC_LENGTH)(SEXP x) { return STDVEC_LENGTH(CHK2(x)); } |
| R_xlen_t (STDVEC_TRUELENGTH)(SEXP x) { return STDVEC_TRUELENGTH(CHK2(x)); } |
| void (SETALTREP)(SEXP x, int v) { SETALTREP(x, v); } |
| #endif |
| |
| /* temporary, to ease transition away from remapping */ |
| R_xlen_t Rf_XLENGTH(SEXP x) { return XLENGTH(x); } |
| |
| const char *(R_CHAR)(SEXP x) { |
| if(TYPEOF(x) != CHARSXP) // Han-Tak proposes to prepend 'x && ' |
| error("%s() can only be applied to a '%s', not a '%s'", |
| "CHAR", "CHARSXP", type2char(TYPEOF(x))); |
| return (const char *) CHAR(CHK(x)); |
| } |
| |
| SEXP (STRING_ELT)(SEXP x, R_xlen_t i) { |
| if(TYPEOF(x) != STRSXP) |
| error("%s() can only be applied to a '%s', not a '%s'", |
| "STRING_ELT", "character vector", type2char(TYPEOF(x))); |
| if (ALTREP(x)) |
| return CHK(ALTSTRING_ELT(CHK(x), i)); |
| else { |
| SEXP *ps = STDVEC_DATAPTR(CHK(x)); |
| return CHK(ps[i]); |
| } |
| } |
| |
| SEXP (VECTOR_ELT)(SEXP x, R_xlen_t i) { |
| /* We need to allow vector-like types here */ |
| if(TYPEOF(x) != VECSXP && |
| TYPEOF(x) != EXPRSXP && |
| TYPEOF(x) != WEAKREFSXP) |
| error("%s() can only be applied to a '%s', not a '%s'", |
| "VECTOR_ELT", "list", type2char(TYPEOF(x))); |
| return CHK(VECTOR_ELT(CHK(x), i)); |
| } |
| |
| #ifdef CATCH_ZERO_LENGTH_ACCESS |
| /* Attempts to read or write elements of a zero length vector will |
| result in a segfault, rather than read and write random memory. |
| Returning NULL would be more natural, but Matrix seems to assume |
| that even zero-length vectors have non-NULL data pointers, so |
| return (void *) 1 instead. Zero-length CHARSXP objects still have a |
| trailing zero byte so they are not handled. */ |
| # define CHKZLN(x) do { \ |
| CHK(x); \ |
| if (STDVEC_LENGTH(x) == 0 && TYPEOF(x) != CHARSXP) \ |
| return (void *) 1; \ |
| } while (0) |
| #else |
| # define CHKZLN(x) do { } while (0) |
| #endif |
| |
| void *(STDVEC_DATAPTR)(SEXP x) |
| { |
| if (ALTREP(x)) |
| error("cannot get STDVEC_DATAPTR from ALTREP object"); |
| if (! isVector(x) && TYPEOF(x) != WEAKREFSXP) |
| error("STDVEC_DATAPTR can only be applied to a vector, not a '%s'", |
| type2char(TYPEOF(x))); |
| CHKZLN(x); |
| return STDVEC_DATAPTR(x); |
| } |
| |
| int *(LOGICAL)(SEXP x) { |
| if(TYPEOF(x) != LGLSXP) |
| error("%s() can only be applied to a '%s', not a '%s'", |
| "LOGICAL", "logical", type2char(TYPEOF(x))); |
| CHKZLN(x); |
| return LOGICAL(x); |
| } |
| |
| const int *(LOGICAL_RO)(SEXP x) { |
| if(TYPEOF(x) != LGLSXP) |
| error("%s() can only be applied to a '%s', not a '%s'", |
| "LOGICAL", "logical", type2char(TYPEOF(x))); |
| CHKZLN(x); |
| return LOGICAL_RO(x); |
| } |
| |
| /* Maybe this should exclude logicals, but it is widely used */ |
| int *(INTEGER)(SEXP x) { |
| if(TYPEOF(x) != INTSXP && TYPEOF(x) != LGLSXP) |
| error("%s() can only be applied to a '%s', not a '%s'", |
| "INTEGER", "integer", type2char(TYPEOF(x))); |
| CHKZLN(x); |
| return INTEGER(x); |
| } |
| |
| const int *(INTEGER_RO)(SEXP x) { |
| if(TYPEOF(x) != INTSXP && TYPEOF(x) != LGLSXP) |
| error("%s() can only be applied to a '%s', not a '%s'", |
| "INTEGER", "integer", type2char(TYPEOF(x))); |
| CHKZLN(x); |
| return INTEGER_RO(x); |
| } |
| |
| Rbyte *(RAW)(SEXP x) { |
| if(TYPEOF(x) != RAWSXP) |
| error("%s() can only be applied to a '%s', not a '%s'", |
| "RAW", "raw", type2char(TYPEOF(x))); |
| CHKZLN(x); |
| return RAW(x); |
| } |
| |
| const Rbyte *(RAW_RO)(SEXP x) { |
| if(TYPEOF(x) != RAWSXP) |
| error("%s() can only be applied to a '%s', not a '%s'", |
| "RAW", "raw", type2char(TYPEOF(x))); |
| CHKZLN(x); |
| return RAW(x); |
| } |
| |
| double *(REAL)(SEXP x) { |
| if(TYPEOF(x) != REALSXP) |
| error("%s() can only be applied to a '%s', not a '%s'", |
| "REAL", "numeric", type2char(TYPEOF(x))); |
| CHKZLN(x); |
| return REAL(x); |
| } |
| |
| const double *(REAL_RO)(SEXP x) { |
| if(TYPEOF(x) != REALSXP) |
| error("%s() can only be applied to a '%s', not a '%s'", |
| "REAL", "numeric", type2char(TYPEOF(x))); |
| CHKZLN(x); |
| return REAL_RO(x); |
| } |
| |
| Rcomplex *(COMPLEX)(SEXP x) { |
| if(TYPEOF(x) != CPLXSXP) |
| error("%s() can only be applied to a '%s', not a '%s'", |
| "COMPLEX", "complex", type2char(TYPEOF(x))); |
| CHKZLN(x); |
| return COMPLEX(x); |
| } |
| |
| const Rcomplex *(COMPLEX_RO)(SEXP x) { |
| if(TYPEOF(x) != CPLXSXP) |
| error("%s() can only be applied to a '%s', not a '%s'", |
| "COMPLEX", "complex", type2char(TYPEOF(x))); |
| CHKZLN(x); |
| return COMPLEX_RO(x); |
| } |
| |
| SEXP *(STRING_PTR)(SEXP x) { |
| if(TYPEOF(x) != STRSXP) |
| error("%s() can only be applied to a '%s', not a '%s'", |
| "STRING_PTR", "character", type2char(TYPEOF(x))); |
| CHKZLN(x); |
| return STRING_PTR(x); |
| } |
| |
| const SEXP *(STRING_PTR_RO)(SEXP x) { |
| if(TYPEOF(x) != STRSXP) |
| error("%s() can only be applied to a '%s', not a '%s'", |
| "STRING_PTR_RO", "character", type2char(TYPEOF(x))); |
| CHKZLN(x); |
| return STRING_PTR_RO(x); |
| } |
| |
| SEXP * NORET (VECTOR_PTR)(SEXP x) |
| { |
| error(_("not safe to return vector pointer")); |
| } |
| |
| void (SET_STRING_ELT)(SEXP x, R_xlen_t i, SEXP v) { |
| if(TYPEOF(CHK(x)) != STRSXP) |
| error("%s() can only be applied to a '%s', not a '%s'", |
| "SET_STRING_ELT", "character vector", type2char(TYPEOF(x))); |
| if(TYPEOF(CHK(v)) != CHARSXP) |
| error("Value of SET_STRING_ELT() must be a 'CHARSXP' not a '%s'", |
| type2char(TYPEOF(v))); |
| if (i < 0 || i >= XLENGTH(x)) |
| error(_("attempt to set index %lld/%lld in SET_STRING_ELT"), |
| (long long)i, (long long)XLENGTH(x)); |
| CHECK_OLD_TO_NEW(x, v); |
| if (ALTREP(x)) |
| ALTSTRING_SET_ELT(x, i, v); |
| else { |
| SEXP *ps = STDVEC_DATAPTR(x); |
| FIX_REFCNT(x, ps[i], v); |
| ps[i] = v; |
| } |
| } |
| |
| SEXP (SET_VECTOR_ELT)(SEXP x, R_xlen_t i, SEXP v) { |
| /* we need to allow vector-like types here */ |
| if(TYPEOF(x) != VECSXP && |
| TYPEOF(x) != EXPRSXP && |
| TYPEOF(x) != WEAKREFSXP) { |
| error("%s() can only be applied to a '%s', not a '%s'", |
| "SET_VECTOR_ELT", "list", type2char(TYPEOF(x))); |
| } |
| if (i < 0 || i >= XLENGTH(x)) |
| error(_("attempt to set index %lld/%lld in SET_VECTOR_ELT"), |
| (long long)i, (long long)XLENGTH(x)); |
| FIX_REFCNT(x, VECTOR_ELT(x, i), v); |
| CHECK_OLD_TO_NEW(x, v); |
| return VECTOR_ELT(x, i) = v; |
| } |
| |
| /* check for a CONS-like object */ |
| #ifdef TESTING_WRITE_BARRIER |
| static R_INLINE SEXP CHKCONS(SEXP e) |
| { |
| if (ALTREP(e)) |
| return CHK(e); |
| switch (TYPEOF(e)) { |
| case LISTSXP: |
| case LANGSXP: |
| case NILSXP: |
| case DOTSXP: |
| case CLOSXP: /**** use separate accessors? */ |
| case BCODESXP: /**** use separate accessors? */ |
| case ENVSXP: /**** use separate accessors? */ |
| case PROMSXP: /**** use separate accessors? */ |
| case EXTPTRSXP: /**** use separate accessors? */ |
| return CHK(e); |
| default: |
| error("CAR/CDR/TAG or similar applied to %s object", |
| type2char(TYPEOF(e))); |
| } |
| } |
| #else |
| #define CHKCONS(e) CHK(e) |
| #endif |
| |
| /* List Accessors */ |
| SEXP (TAG)(SEXP e) { return CHK(TAG(CHKCONS(e))); } |
| SEXP (CAR)(SEXP e) { return CHK(CAR(CHKCONS(e))); } |
| SEXP (CDR)(SEXP e) { return CHK(CDR(CHKCONS(e))); } |
| SEXP (CAAR)(SEXP e) { return CHK(CAAR(CHKCONS(e))); } |
| SEXP (CDAR)(SEXP e) { return CHK(CDAR(CHKCONS(e))); } |
| SEXP (CADR)(SEXP e) { return CHK(CADR(CHKCONS(e))); } |
| SEXP (CDDR)(SEXP e) { return CHK(CDDR(CHKCONS(e))); } |
| SEXP (CDDDR)(SEXP e) { return CHK(CDDDR(CHKCONS(e))); } |
| SEXP (CADDR)(SEXP e) { return CHK(CADDR(CHKCONS(e))); } |
| SEXP (CADDDR)(SEXP e) { return CHK(CADDDR(CHKCONS(e))); } |
| SEXP (CAD4R)(SEXP e) { return CHK(CAD4R(CHKCONS(e))); } |
| int (MISSING)(SEXP x) { return MISSING(CHKCONS(x)); } |
| |
| void (SET_TAG)(SEXP x, SEXP v) |
| { |
| if (CHKCONS(x) == NULL || x == R_NilValue) |
| error(_("bad value")); |
| FIX_REFCNT(x, TAG(x), v); |
| CHECK_OLD_TO_NEW(x, v); |
| TAG(x) = v; |
| } |
| |
| SEXP (SETCAR)(SEXP x, SEXP y) |
| { |
| if (CHKCONS(x) == NULL || x == R_NilValue) |
| error(_("bad value")); |
| FIX_REFCNT(x, CAR(x), y); |
| CHECK_OLD_TO_NEW(x, y); |
| CAR(x) = y; |
| return y; |
| } |
| |
| SEXP (SETCDR)(SEXP x, SEXP y) |
| { |
| if (CHKCONS(x) == NULL || x == R_NilValue) |
| error(_("bad value")); |
| FIX_REFCNT(x, CDR(x), y); |
| CHECK_OLD_TO_NEW(x, y); |
| CDR(x) = y; |
| return y; |
| } |
| |
| SEXP (SETCADR)(SEXP x, SEXP y) |
| { |
| SEXP cell; |
| if (CHKCONS(x) == NULL || x == R_NilValue || |
| CHKCONS(CDR(x)) == NULL || CDR(x) == R_NilValue) |
| error(_("bad value")); |
| cell = CDR(x); |
| FIX_REFCNT(cell, CAR(cell), y); |
| CHECK_OLD_TO_NEW(cell, y); |
| CAR(cell) = y; |
| return y; |
| } |
| |
| SEXP (SETCADDR)(SEXP x, SEXP y) |
| { |
| SEXP cell; |
| if (CHKCONS(x) == NULL || x == R_NilValue || |
| CHKCONS(CDR(x)) == NULL || CDR(x) == R_NilValue || |
| CHKCONS(CDDR(x)) == NULL || CDDR(x) == R_NilValue) |
| error(_("bad value")); |
| cell = CDDR(x); |
| FIX_REFCNT(cell, CAR(cell), y); |
| CHECK_OLD_TO_NEW(cell, y); |
| CAR(cell) = y; |
| return y; |
| } |
| |
| SEXP (SETCADDDR)(SEXP x, SEXP y) |
| { |
| SEXP cell; |
| if (CHKCONS(x) == NULL || x == R_NilValue || |
| CHKCONS(CDR(x)) == NULL || CDR(x) == R_NilValue || |
| CHKCONS(CDDR(x)) == NULL || CDDR(x) == R_NilValue || |
| CHKCONS(CDDDR(x)) == NULL || CDDDR(x) == R_NilValue) |
| error(_("bad value")); |
| cell = CDDDR(x); |
| FIX_REFCNT(cell, CAR(cell), y); |
| CHECK_OLD_TO_NEW(cell, y); |
| CAR(cell) = y; |
| return y; |
| } |
| |
| #define CD4R(x) CDR(CDR(CDR(CDR(x)))) |
| |
| SEXP (SETCAD4R)(SEXP x, SEXP y) |
| { |
| SEXP cell; |
| if (CHKCONS(x) == NULL || x == R_NilValue || |
| CHKCONS(CDR(x)) == NULL || CDR(x) == R_NilValue || |
| CHKCONS(CDDR(x)) == NULL || CDDR(x) == R_NilValue || |
| CHKCONS(CDDDR(x)) == NULL || CDDDR(x) == R_NilValue || |
| CHKCONS(CD4R(x)) == NULL || CD4R(x) == R_NilValue) |
| error(_("bad value")); |
| cell = CD4R(x); |
| FIX_REFCNT(cell, CAR(cell), y); |
| CHECK_OLD_TO_NEW(cell, y); |
| CAR(cell) = y; |
| return y; |
| } |
| |
| void (SET_MISSING)(SEXP x, int v) { SET_MISSING(CHKCONS(x), v); } |
| |
| /* Closure Accessors */ |
| SEXP (FORMALS)(SEXP x) { return CHK(FORMALS(CHK(x))); } |
| SEXP (BODY)(SEXP x) { return CHK(BODY(CHK(x))); } |
| SEXP (CLOENV)(SEXP x) { return CHK(CLOENV(CHK(x))); } |
| int (RDEBUG)(SEXP x) { return RDEBUG(CHK(x)); } |
| int (RSTEP)(SEXP x) { return RSTEP(CHK(x)); } |
| |
| void (SET_FORMALS)(SEXP x, SEXP v) { FIX_REFCNT(x, FORMALS(x), v); CHECK_OLD_TO_NEW(x, v); FORMALS(x) = v; } |
| void (SET_BODY)(SEXP x, SEXP v) { FIX_REFCNT(x, BODY(x), v); CHECK_OLD_TO_NEW(x, v); BODY(x) = v; } |
| void (SET_CLOENV)(SEXP x, SEXP v) { FIX_REFCNT(x, CLOENV(x), v); CHECK_OLD_TO_NEW(x, v); CLOENV(x) = v; } |
| void (SET_RDEBUG)(SEXP x, int v) { SET_RDEBUG(CHK(x), v); } |
| void (SET_RSTEP)(SEXP x, int v) { SET_RSTEP(CHK(x), v); } |
| |
| /* These are only needed with the write barrier on */ |
| #ifdef TESTING_WRITE_BARRIER |
| /* Primitive Accessors */ |
| /* not hidden since needed in some base packages */ |
| int (PRIMOFFSET)(SEXP x) { return PRIMOFFSET(CHK(x)); } |
| attribute_hidden |
| void (SET_PRIMOFFSET)(SEXP x, int v) { SET_PRIMOFFSET(CHK(x), v); } |
| #endif |
| |
| /* Symbol Accessors */ |
| SEXP (PRINTNAME)(SEXP x) { return CHK(PRINTNAME(CHK(x))); } |
| SEXP (SYMVALUE)(SEXP x) { return CHK(SYMVALUE(CHK(x))); } |
| SEXP (INTERNAL)(SEXP x) { return CHK(INTERNAL(CHK(x))); } |
| int (DDVAL)(SEXP x) { return DDVAL(CHK(x)); } |
| |
| void (SET_PRINTNAME)(SEXP x, SEXP v) { FIX_REFCNT(x, PRINTNAME(x), v); CHECK_OLD_TO_NEW(x, v); PRINTNAME(x) = v; } |
| void (SET_SYMVALUE)(SEXP x, SEXP v) { FIX_REFCNT(x, SYMVALUE(x), v); CHECK_OLD_TO_NEW(x, v); SYMVALUE(x) = v; } |
| void (SET_INTERNAL)(SEXP x, SEXP v) { FIX_REFCNT(x, INTERNAL(x), v); CHECK_OLD_TO_NEW(x, v); INTERNAL(x) = v; } |
| void (SET_DDVAL)(SEXP x, int v) { SET_DDVAL(CHK(x), v); } |
| |
| /* Environment Accessors */ |
| SEXP (FRAME)(SEXP x) { return CHK(FRAME(CHK(x))); } |
| SEXP (ENCLOS)(SEXP x) { return CHK(ENCLOS(CHK(x))); } |
| SEXP (HASHTAB)(SEXP x) { return CHK(HASHTAB(CHK(x))); } |
| int (ENVFLAGS)(SEXP x) { return ENVFLAGS(CHK(x)); } |
| |
| void (SET_FRAME)(SEXP x, SEXP v) { FIX_REFCNT(x, FRAME(x), v); CHECK_OLD_TO_NEW(x, v); FRAME(x) = v; } |
| void (SET_ENCLOS)(SEXP x, SEXP v) { FIX_REFCNT(x, ENCLOS(x), v); CHECK_OLD_TO_NEW(x, v); ENCLOS(x) = v; } |
| void (SET_HASHTAB)(SEXP x, SEXP v) { FIX_REFCNT(x, HASHTAB(x), v); CHECK_OLD_TO_NEW(x, v); HASHTAB(x) = v; } |
| void (SET_ENVFLAGS)(SEXP x, int v) { SET_ENVFLAGS(x, v); } |
| |
| /* Promise Accessors */ |
| SEXP (PRCODE)(SEXP x) { return CHK(PRCODE(CHK(x))); } |
| SEXP (PRENV)(SEXP x) { return CHK(PRENV(CHK(x))); } |
| SEXP (PRVALUE)(SEXP x) { return CHK(PRVALUE(CHK(x))); } |
| int (PRSEEN)(SEXP x) { return PRSEEN(CHK(x)); } |
| |
| void (SET_PRENV)(SEXP x, SEXP v){ FIX_REFCNT(x, PRENV(x), v); CHECK_OLD_TO_NEW(x, v); PRENV(x) = v; } |
| void (SET_PRVALUE)(SEXP x, SEXP v) { FIX_REFCNT(x, PRVALUE(x), v); CHECK_OLD_TO_NEW(x, v); PRVALUE(x) = v; } |
| void (SET_PRCODE)(SEXP x, SEXP v) { FIX_REFCNT(x, PRCODE(x), v); CHECK_OLD_TO_NEW(x, v); PRCODE(x) = v; } |
| void (SET_PRSEEN)(SEXP x, int v) { SET_PRSEEN(CHK(x), v); } |
| |
| /* Hashing Accessors */ |
| #ifdef TESTING_WRITE_BARRIER |
| attribute_hidden |
| int (HASHASH)(SEXP x) { return HASHASH(CHK(x)); } |
| attribute_hidden |
| int (HASHVALUE)(SEXP x) { return HASHVALUE(CHK(x)); } |
| |
| attribute_hidden |
| void (SET_HASHASH)(SEXP x, int v) { SET_HASHASH(CHK(x), v); } |
| attribute_hidden |
| void (SET_HASHVALUE)(SEXP x, int v) { SET_HASHVALUE(CHK(x), v); } |
| #endif |
| |
| attribute_hidden |
| SEXP (SET_CXTAIL)(SEXP x, SEXP v) { |
| #ifdef USE_TYPE_CHECKING |
| if(TYPEOF(v) != CHARSXP && TYPEOF(v) != NILSXP) |
| error("value of 'SET_CXTAIL' must be a char or NULL, not a '%s'", |
| type2char(TYPEOF(v))); |
| #endif |
| /*CHECK_OLD_TO_NEW(x, v); *//* not needed since not properly traced */ |
| ATTRIB(x) = v; |
| return x; |
| } |
| |
| /* Test functions */ |
| Rboolean Rf_isNull(SEXP s) { return isNull(CHK(s)); } |
| Rboolean Rf_isSymbol(SEXP s) { return isSymbol(CHK(s)); } |
| Rboolean Rf_isLogical(SEXP s) { return isLogical(CHK(s)); } |
| Rboolean Rf_isReal(SEXP s) { return isReal(CHK(s)); } |
| Rboolean Rf_isComplex(SEXP s) { return isComplex(CHK(s)); } |
| Rboolean Rf_isExpression(SEXP s) { return isExpression(CHK(s)); } |
| Rboolean Rf_isEnvironment(SEXP s) { return isEnvironment(CHK(s)); } |
| Rboolean Rf_isString(SEXP s) { return isString(CHK(s)); } |
| Rboolean Rf_isObject(SEXP s) { return isObject(CHK(s)); } |
| |
| /* Bindings accessors */ |
| Rboolean attribute_hidden |
| (IS_ACTIVE_BINDING)(SEXP b) {return IS_ACTIVE_BINDING(CHK(b));} |
| Rboolean attribute_hidden |
| (BINDING_IS_LOCKED)(SEXP b) {return BINDING_IS_LOCKED(CHK(b));} |
| void attribute_hidden |
| (SET_ACTIVE_BINDING_BIT)(SEXP b) {SET_ACTIVE_BINDING_BIT(CHK(b));} |
| void attribute_hidden (LOCK_BINDING)(SEXP b) {LOCK_BINDING(CHK(b));} |
| void attribute_hidden (UNLOCK_BINDING)(SEXP b) {UNLOCK_BINDING(CHK(b));} |
| |
| attribute_hidden |
| void (SET_BASE_SYM_CACHED)(SEXP b) { SET_BASE_SYM_CACHED(CHK(b)); } |
| attribute_hidden |
| void (UNSET_BASE_SYM_CACHED)(SEXP b) { UNSET_BASE_SYM_CACHED(CHK(b)); } |
| attribute_hidden |
| Rboolean (BASE_SYM_CACHED)(SEXP b) { return BASE_SYM_CACHED(CHK(b)); } |
| |
| attribute_hidden |
| void (SET_SPECIAL_SYMBOL)(SEXP b) { SET_SPECIAL_SYMBOL(CHK(b)); } |
| attribute_hidden |
| void (UNSET_SPECIAL_SYMBOL)(SEXP b) { UNSET_SPECIAL_SYMBOL(CHK(b)); } |
| attribute_hidden |
| Rboolean (IS_SPECIAL_SYMBOL)(SEXP b) { return IS_SPECIAL_SYMBOL(CHK(b)); } |
| attribute_hidden |
| void (SET_NO_SPECIAL_SYMBOLS)(SEXP b) { SET_NO_SPECIAL_SYMBOLS(CHK(b)); } |
| attribute_hidden |
| void (UNSET_NO_SPECIAL_SYMBOLS)(SEXP b) { UNSET_NO_SPECIAL_SYMBOLS(CHK(b)); } |
| attribute_hidden |
| Rboolean (NO_SPECIAL_SYMBOLS)(SEXP b) { return NO_SPECIAL_SYMBOLS(CHK(b)); } |
| |
| /* R_FunTab accessors, only needed when write barrier is on */ |
| /* Not hidden to allow experimentaiton without rebuilding R - LT */ |
| /* attribute_hidden */ |
| int (PRIMVAL)(SEXP x) { return PRIMVAL(CHK(x)); } |
| /* attribute_hidden */ |
| CCODE (PRIMFUN)(SEXP x) { return PRIMFUN(CHK(x)); } |
| /* attribute_hidden */ |
| void (SET_PRIMFUN)(SEXP x, CCODE f) { PRIMFUN(CHK(x)) = f; } |
| |
| /* for use when testing the write barrier */ |
| int attribute_hidden (IS_BYTES)(SEXP x) { return IS_BYTES(CHK(x)); } |
| int attribute_hidden (IS_LATIN1)(SEXP x) { return IS_LATIN1(CHK(x)); } |
| int attribute_hidden (IS_ASCII)(SEXP x) { return IS_ASCII(CHK(x)); } |
| int attribute_hidden (IS_UTF8)(SEXP x) { return IS_UTF8(CHK(x)); } |
| void attribute_hidden (SET_BYTES)(SEXP x) { SET_BYTES(CHK(x)); } |
| void attribute_hidden (SET_LATIN1)(SEXP x) { SET_LATIN1(CHK(x)); } |
| void attribute_hidden (SET_UTF8)(SEXP x) { SET_UTF8(CHK(x)); } |
| void attribute_hidden (SET_ASCII)(SEXP x) { SET_ASCII(CHK(x)); } |
| int (ENC_KNOWN)(SEXP x) { return ENC_KNOWN(CHK(x)); } |
| void attribute_hidden (SET_CACHED)(SEXP x) { SET_CACHED(CHK(x)); } |
| int (IS_CACHED)(SEXP x) { return IS_CACHED(CHK(x)); } |
| |
| /*******************************************/ |
| /* Non-sampling memory use profiler |
| reports all large vector heap |
| allocations and all calls to GetNewPage */ |
| /*******************************************/ |
| |
| #ifndef R_MEMORY_PROFILING |
| |
| SEXP NORET do_Rprofmem(SEXP args) |
| { |
| error(_("memory profiling is not available on this system")); |
| } |
| |
| #else |
| static int R_IsMemReporting; /* Rboolean more appropriate? */ |
| static FILE *R_MemReportingOutfile; |
| static R_size_t R_MemReportingThreshold; |
| |
| static void R_OutputStackTrace(FILE *file) |
| { |
| RCNTXT *cptr; |
| |
| for (cptr = R_GlobalContext; cptr; cptr = cptr->nextcontext) { |
| if ((cptr->callflag & (CTXT_FUNCTION | CTXT_BUILTIN)) |
| && TYPEOF(cptr->call) == LANGSXP) { |
| SEXP fun = CAR(cptr->call); |
| fprintf(file, "\"%s\" ", |
| TYPEOF(fun) == SYMSXP ? CHAR(PRINTNAME(fun)) : |
| "<Anonymous>"); |
| } |
| } |
| } |
| |
| static void R_ReportAllocation(R_size_t size) |
| { |
| if (R_IsMemReporting) { |
| if(size > R_MemReportingThreshold) { |
| fprintf(R_MemReportingOutfile, "%lu :", (unsigned long) size); |
| R_OutputStackTrace(R_MemReportingOutfile); |
| fprintf(R_MemReportingOutfile, "\n"); |
| } |
| } |
| return; |
| } |
| |
| static void R_ReportNewPage(void) |
| { |
| if (R_IsMemReporting) { |
| fprintf(R_MemReportingOutfile, "new page:"); |
| R_OutputStackTrace(R_MemReportingOutfile); |
| fprintf(R_MemReportingOutfile, "\n"); |
| } |
| return; |
| } |
| |
| static void R_EndMemReporting() |
| { |
| if(R_MemReportingOutfile != NULL) { |
| /* does not fclose always flush? */ |
| fflush(R_MemReportingOutfile); |
| fclose(R_MemReportingOutfile); |
| R_MemReportingOutfile=NULL; |
| } |
| R_IsMemReporting = 0; |
| return; |
| } |
| |
| static void R_InitMemReporting(SEXP filename, int append, |
| R_size_t threshold) |
| { |
| if(R_MemReportingOutfile != NULL) R_EndMemReporting(); |
| R_MemReportingOutfile = RC_fopen(filename, append ? "a" : "w", TRUE); |
| if (R_MemReportingOutfile == NULL) |
| error(_("Rprofmem: cannot open output file '%s'"), filename); |
| R_MemReportingThreshold = threshold; |
| R_IsMemReporting = 1; |
| return; |
| } |
| |
| SEXP do_Rprofmem(SEXP args) |
| { |
| SEXP filename; |
| R_size_t threshold; |
| int append_mode; |
| |
| if (!isString(CAR(args)) || (LENGTH(CAR(args))) != 1) |
| error(_("invalid '%s' argument"), "filename"); |
| append_mode = asLogical(CADR(args)); |
| filename = STRING_ELT(CAR(args), 0); |
| threshold = (R_size_t) REAL(CADDR(args))[0]; |
| if (strlen(CHAR(filename))) |
| R_InitMemReporting(filename, append_mode, threshold); |
| else |
| R_EndMemReporting(); |
| return R_NilValue; |
| } |
| |
| #endif /* R_MEMORY_PROFILING */ |
| |
| /* RBufferUtils, moved from deparse.c */ |
| |
| #include "RBufferUtils.h" |
| |
| void *R_AllocStringBuffer(size_t blen, R_StringBuffer *buf) |
| { |
| size_t blen1, bsize = buf->defaultSize; |
| |
| /* for backwards compatibility, this used to free the buffer */ |
| if(blen == (size_t)-1) |
| error("R_AllocStringBuffer( (size_t)-1 ) is no longer allowed"); |
| |
| if(blen * sizeof(char) < buf->bufsize) return buf->data; |
| blen1 = blen = (blen + 1) * sizeof(char); |
| blen = (blen / bsize) * bsize; |
| if(blen < blen1) blen += bsize; |
| |
| if(buf->data == NULL) { |
| buf->data = (char *) malloc(blen); |
| if(buf->data) |
| buf->data[0] = '\0'; |
| } else |
| buf->data = (char *) realloc(buf->data, blen); |
| buf->bufsize = blen; |
| if(!buf->data) { |
| buf->bufsize = 0; |
| /* don't translate internal error message */ |
| error("could not allocate memory (%u Mb) in C function 'R_AllocStringBuffer'", |
| (unsigned int) blen/1024/1024); |
| } |
| return buf->data; |
| } |
| |
| void |
| R_FreeStringBuffer(R_StringBuffer *buf) |
| { |
| if (buf->data != NULL) { |
| free(buf->data); |
| buf->bufsize = 0; |
| buf->data = NULL; |
| } |
| } |
| |
| void attribute_hidden |
| R_FreeStringBufferL(R_StringBuffer *buf) |
| { |
| if (buf->bufsize > buf->defaultSize) { |
| free(buf->data); |
| buf->bufsize = 0; |
| buf->data = NULL; |
| } |
| } |
| |
| /* ======== This needs direct access to gp field for efficiency ======== */ |
| |
| /* this has NA_STRING = NA_STRING */ |
| attribute_hidden |
| int Seql(SEXP a, SEXP b) |
| { |
| /* The only case where pointer comparisons do not suffice is where |
| we have two strings in different encodings (which must be |
| non-ASCII strings). Note that one of the strings could be marked |
| as unknown. */ |
| if (a == b) return 1; |
| /* Leave this to compiler to optimize */ |
| if (IS_CACHED(a) && IS_CACHED(b) && ENC_KNOWN(a) == ENC_KNOWN(b)) |
| return 0; |
| else { |
| SEXP vmax = R_VStack; |
| int result = !strcmp(translateCharUTF8(a), translateCharUTF8(b)); |
| R_VStack = vmax; /* discard any memory used by translateCharUTF8 */ |
| return result; |
| } |
| } |
| |
| |
| #ifdef LONG_VECTOR_SUPPORT |
| R_len_t NORET R_BadLongVector(SEXP x, const char *file, int line) |
| { |
| error(_("long vectors not supported yet: %s:%d"), file, line); |
| } |
| #endif |
