The R Project SVN – R – Blame – /branches/R-Win-CMD/src/main/memory.c

Rev	Author	Line No.	Line
2	r	1	`/*`
1160	maechler	2	`* R : A Computer Language for Statistical Data Analysis`
2	r	3	`* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka`
24516	ripley	4	`* Copyright (C) 1998--2003 The R Development Core Team.`
2	r	5	`*`
		6	`* This program is free software; you can redistribute it and/or modify`
		7	`* it under the terms of the GNU General Public License as published by`
		8	`* the Free Software Foundation; either version 2 of the License, or`
		9	`* (at your option) any later version.`
		10	`*`
		11	`* This program is distributed in the hope that it will be useful,`
		12	`* but WITHOUT ANY WARRANTY; without even the implied warranty of`
		13	`* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the`
		14	`* GNU General Public License for more details.`
		15	`*`
		16	`* You should have received a copy of the GNU General Public License`
		17	`* along with this program; if not, write to the Free Software`
5458	ripley	18	`* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA`
10172	luke	19	`*/`
11116	ripley	20
10172	luke	21	`/*`
11197	ripley	22	`* This code implements a non-moving generational collector`
11116	ripley	23	`* with two or three generations.`
1820	ihaka	24	`*`
10172	luke	25	`* Memory allocated by R_alloc is maintained in a stack. Code`
		26	`* that R_allocs memory must use vmaxget and vmaxset to obtain`
		27	`* and reset the stack pointer.`
		28	`*/`
239	ihaka	29
10172	luke	30	`#define USE_RINTERNALS`
		31
5187	hornik	32	`#ifdef HAVE_CONFIG_H`
7701	hornik	33	`#include <config.h>`
5187	hornik	34	`#endif`
		35
26879	ripley	36	`#if defined(Win32) && defined(LEA_MALLOC)`
		37	`#include <stddef.h>`
		38	`extern void *Rm_malloc(size_t n);`
		39	`extern void *Rm_calloc(size_t n_elements, size_t element_size);`
		40	`extern void Rm_free(void * p);`
		41	`extern void Rm_realloc(void p, size_t n);`
		42	`#define calloc Rm_calloc`
		43	`#define malloc Rm_malloc`
		44	`#define realloc Rm_realloc`
		45	`#define free Rm_free`
		46	`#endif`
		47
11510	ripley	48	`#include <Defn.h>`
		49	`#include <Graphics.h> /* display lists */`
12778	pd	50	`#include <Rdevices.h> /* GetDevice */`
1820	ihaka	51
20094	ripley	52	`/* malloc uses size_t. We are assuming here that size_t is at least`
		53	`as large as unsigned long. Changed from int at 1.6.0 to (i) allow`
		54	`2-4Gb objects on 32-bit system and (ii) objects limited only by`
		55	`length on a 64-bit system.`
		56	`*/`
		57
2	r	58	`static int gc_reporting = 0;`
1858	ihaka	59	`static int gc_count = 0;`
1160	maechler	60
2512	pd	61	`#define GC_TORTURE`
2100	pd	62
		63	`#ifdef GC_TORTURE`
11116	ripley	64	`# define FORCE_GC !gc_inhibit_torture`
2437	maechler	65	`#else`
11116	ripley	66	`# define FORCE_GC 0`
2100	pd	67	`#endif`
		68
2754	pd	69	`extern SEXP framenames;`
2100	pd	70
		71	`#define GC_PROT(X) {int __t = gc_inhibit_torture; \`
		72	`gc_inhibit_torture = 1 ; X ; gc_inhibit_torture = __t;}`
		73
20094	ripley	74	`static void R_gc_internal(R_size_t size_needed);`
		75	`static void mem_err_heap(R_size_t size);`
2	r	76
10172	luke	77	`static SEXPREC UnmarkedNodeTemplate;`
		78	`#define NODE_IS_MARKED(s) (MARK(s)==1)`
		79	`#define MARK_NODE(s) (MARK(s)=1)`
		80	`#define UNMARK_NODE(s) (MARK(s)=0)`
1820	ihaka	81
10172	luke	82
		83	`/* Tuning Constants. Most of these could be made settable from R,`
		84	`within some reasonable constraints at least. Since there are quite`
		85	`a lot of constants it would probably make sense to put together`
		86	`several "packages" representing different space/speed tradeoffs`
		87	`(e.g. very aggressive freeing and small increments to conserve`
		88	`memory; much less frequent releasing and larger increments to`
		89	`increase speed). */`
		90
		91	`/* There are three levels of collections. Level 0 collects only the`
		92	`youngest generation, level 1 collects the two youngest generations,`
		93	`and level 2 collects all generations. Higher level collections`
		94	`occur at least after specified numbers of lower level ones. After`
		95	`LEVEL_0_FREQ level zero collections a level 1 collection is done;`
		96	`after every LEVEL_1_FREQ level 1 collections a level 2 collection`
		97	`occurs. Thus, roughly, every LEVEL_0_FREQ-th collection is a level`
		98	`1 collection and every (LEVEL_0_FREQ * LEVEL_1_FREQ)-th collection`
		99	`is a level 2 collection. */`
		100	`#define LEVEL_0_FREQ 20`
		101	`#define LEVEL_1_FREQ 5`
		102	`static int collect_counts_max[] = { LEVEL_0_FREQ, LEVEL_1_FREQ };`
		103
		104	`/* When a level N collection fails to produce at least MinFreeFrac *`
11135	luke	105	`R_NSize free nodes and MinFreeFrac * R_VSize free vector space, the`
		106	`next collection will be a level N + 1 collection.`
		107
		108	`This constant is also used in heap size adjustment as a minimal`
		109	`fraction of the minimal heap size levels that should be available`
		110	`for allocation. */`
10172	luke	111	`static double R_MinFreeFrac = 0.2;`
		112
		113	`/* When pages are released, a number of free nodes equal to`
		114	`R_MaxKeepFrac times the number of allocated nodes for each class is`
		115	`retained. Pages not needed to meet this requirement are released.`
		116	`An attempt to release pages is made every R_PageReleaseFreq level 1`
		117	`or level 2 collections. */`
		118	`static double R_MaxKeepFrac = 0.5;`
		119	`static int R_PageReleaseFreq = 1;`
		120
		121	`/* The heap size constants R_NSize and R_VSize are used for triggering`
		122	`collections. The initial values set by defaults or command line`
		123	`arguments are used as minimal values. After full collections these`
11135	luke	124	`levels are adjusted up or down, though not below the minimal values`
		125	`or above the maximum values, towards maintain heap occupancy within`
		126	`a specified range. When the number of nodes in use reaches`
		127	`R_NGrowFrac * R_NSize, the value of R_NSize is incremented by`
		128	`R_NGrowIncrMin + R_NGrowIncrFrac * R_NSize. When the number of`
		129	`nodes in use falls below R_NShrinkFrac, R_NSize is decremented by`
		130	`R_NShrinkIncrMin * R_NShrinkFrac * R_NSize. Analogous adjustments`
11197	ripley	131	`are made to R_VSize.`
11135	luke	132
		133	`This mechanism for adjusting the heap size constants is very`
		134	`primitive but hopefully adequate for now. Some modeling and`
		135	`experimentation would be useful. We want the heap sizes to get set`
		136	`at levels adequate for the current computations. The present`
		137	`mechanism uses only the size of the current live heap to provide`
		138	`information about the current needs; since the current live heap`
		139	`size can be very volatile, the adjustment mechanism only makes`
		140	`gradual adjustments. A more sophisticated strategy would use more`
		141	`of the live heap history. */`
10172	luke	142	`static double R_NGrowFrac = 0.70;`
		143	`static double R_NShrinkFrac = 0.30;`
		144
		145	`static double R_VGrowFrac = 0.70;`
		146	`static double R_VShrinkFrac = 0.30;`
		147
11135	luke	148	`#ifdef SMALL_MEMORY`
		149	`/* On machines with only 32M of memory (or on a classic Mac OS port)`
		150	`it might be a good idea to use settings like these that are more`
		151	`aggressive at keeping memory usage down. */`
		152	`static double R_NGrowIncrFrac = 0.0, R_NShrinkIncrFrac = 0.2;`
		153	`static int R_NGrowIncrMin = 50000, R_NShrinkIncrMin = 0;`
		154	`static double R_VGrowIncrFrac = 0.0, R_VShrinkIncrFrac = 0.2;`
		155	`static int R_VGrowIncrMin = 100000, R_VShrinkIncrMin = 0;`
		156	`#else`
		157	`static double R_NGrowIncrFrac = 0.05, R_NShrinkIncrFrac = 0.2;`
		158	`static int R_NGrowIncrMin = 40000, R_NShrinkIncrMin = 0;`
		159	`static double R_VGrowIncrFrac = 0.05, R_VShrinkIncrFrac = 0.2;`
		160	`static int R_VGrowIncrMin = 80000, R_VShrinkIncrMin = 0;`
		161	`#endif`
		162
10172	luke	163	`/* Maximal Heap Limits. These variables contain upper limits on the`
		164	`heap sizes. They could be made adjustable from the R level,`
20094	ripley	165	`perhaps by a handler for a recoverable error.`
11135	luke	166
		167	`Access to these values is provided with reader and writer`
		168	`functions; the writer function insures that the maximal values are`
		169	`never set below the current ones. */`
20094	ripley	170	`static R_size_t R_MaxVSize = R_SIZE_T_MAX;`
		171	`static R_size_t R_MaxNSize = R_SIZE_T_MAX;`
11197	ripley	172	`static int vsfac = 1; /* current units for vsize: changes at initialization */`
10172	luke	173
20094	ripley	174	`R_size_t R_GetMaxVSize(void)`
11197	ripley	175	`{`
20094	ripley	176	`if (R_MaxVSize == R_SIZE_T_MAX) return R_SIZE_T_MAX;`
11197	ripley	177	`return R_MaxVSize*vsfac;`
		178	`}`
11135	luke	179
20094	ripley	180	`void R_SetMaxVSize(R_size_t size)`
11197	ripley	181	`{`
20094	ripley	182	`if (size == R_SIZE_T_MAX) return;`
11297	luke	183	`if (size / vsfac >= R_VSize) R_MaxVSize = (size+1)/sizeof(VECREC);`
11197	ripley	184	`}`
11135	luke	185
20094	ripley	186	`R_size_t R_GetMaxNSize(void)`
11197	ripley	187	`{`
		188	`return R_MaxNSize;`
		189	`}`
11135	luke	190
20094	ripley	191	`void R_SetMaxNSize(R_size_t size)`
11197	ripley	192	`{`
		193	`if (size >= R_NSize) R_MaxNSize = size;`
		194	`}`
		195
27067	ripley	196	`void R_SetPPSize(unsigned long size)`
		197	`{`
		198	`R_PPStackSize = size;`
		199	`}`
11197	ripley	200
10172	luke	201	`/* Miscellaneous Globals. */`
		202
		203	`static SEXP R_VStack = NULL; /* R_alloc stack pointer */`
20094	ripley	204	`static R_size_t R_LargeVallocSize = 0;`
		205	`static R_size_t R_SmallVallocSize = 0;`
		206	`static R_size_t orig_R_NSize;`
		207	`static R_size_t orig_R_VSize;`
10172	luke	208
		209
		210	`/* Node Classes. Non-vector nodes are of class zero. Small vector`
		211	`nodes are in classes 1, ..., NUM_SMALL_NODE_CLASSES, and large`
		212	`vector nodes are in class LARGE_NODE_CLASS. For vector nodes the`
		213	`node header is followed in memory by the vector data, offset from`
		214	`the header by SEXPREC_ALIGN. */`
		215
		216	`#define NUM_NODE_CLASSES 8`
		217
		218	`/* sxpinfo allocates 3 bits for the node class, so at most 8 are allowed */`
		219	`#if NUM_NODE_CLASSES > 8`
11116	ripley	220	`# error NUM_NODE_CLASSES must be at most 8`
10172	luke	221	`#endif`
		222
		223	`#define LARGE_NODE_CLASS (NUM_NODE_CLASSES - 1)`
		224	`#define NUM_SMALL_NODE_CLASSES (NUM_NODE_CLASSES - 1)`
		225
		226	`/* the number of VECREC's in nodes of the small node classes */`
		227	`static int NodeClassSize[NUM_SMALL_NODE_CLASSES] = { 0, 1, 2, 4, 6, 8, 16 };`
		228
		229	`#define NODE_CLASS(s) ((s)->sxpinfo.gccls)`
		230	`#define SET_NODE_CLASS(s,v) (((s)->sxpinfo.gccls) = (v))`
		231
		232
		233	`/* Node Generations. */`
		234
		235	`#define NUM_OLD_GENERATIONS 2`
		236
		237	`/* sxpinfo allocates one bit for the old generation count, so only 1`
		238	`or 2 is allowed */`
		239	`#if NUM_OLD_GENERATIONS > 2 \|\| NUM_OLD_GENERATIONS < 1`
11116	ripley	240	`# error number of old generations must be 1 or 2`
10172	luke	241	`#endif`
		242
		243	`#define NODE_GENERATION(s) ((s)->sxpinfo.gcgen)`
		244	`#define SET_NODE_GENERATION(s,g) ((s)->sxpinfo.gcgen=(g))`
		245
		246	`#define NODE_GEN_IS_YOUNGER(s,g) \`
		247	`(! NODE_IS_MARKED(s) \|\| NODE_GENERATION(s) < (g))`
		248	`#define NODE_IS_OLDER(x, y) \`
		249	`(NODE_IS_MARKED(x) && \`
		250	`(! NODE_IS_MARKED(y) \|\| NODE_GENERATION(x) > NODE_GENERATION(y)))`
		251
		252	`static int num_old_gens_to_collect = 0;`
		253	`static int gen_gc_counts[NUM_OLD_GENERATIONS + 1];`
		254	`static int collect_counts[NUM_OLD_GENERATIONS];`
		255
		256
		257	`/* Node Pages. Non-vector nodes and small vector nodes are allocated`
		258	`from fixed size pages. The pages for each node class are kept in a`
		259	`linked list. */`
		260
		261	`typedef union PAGE_HEADER {`
		262	`union PAGE_HEADER *next;`
		263	`double align;`
		264	`} PAGE_HEADER;`
		265
		266	`#define BASE_PAGE_SIZE 2000`
10286	luke	267	`#define R_PAGE_SIZE \`
10172	luke	268	`(((BASE_PAGE_SIZE - sizeof(PAGE_HEADER)) / sizeof(SEXPREC)) \`
		269	`* sizeof(SEXPREC) \`
		270	`+ sizeof(PAGE_HEADER))`
		271	`#define NODE_SIZE(c) \`
		272	`((c) == 0 ? sizeof(SEXPREC) : \`
		273	`sizeof(SEXPREC_ALIGN) + NodeClassSize[c] * sizeof(VECREC))`
		274
		275	`#define PAGE_DATA(p) ((void *) (p + 1))`
		276	`#define VHEAP_FREE() (R_VSize - R_LargeVallocSize - R_SmallVallocSize)`
		277
		278
		279	`/* The Heap Structure. Nodes for each class/generation combination`
		280	`are arranged in circular doubly-linked lists. The double linking`
		281	`allows nodes to be removed in constant time; this is used by the`
		282	`collector to move reachable nodes out of free space and into the`
		283	`appropriate generation. The circularity eliminates the need for`
		284	`end checks. In addition, each link is anchored at an artificial`
		285	`node, the Peg SEXPREC's in the structure below, which simplifies`
		286	`pointer maintenance. The circular doubly-linked arrangement is`
		287	`taken from Baker's in-place incremental collector design; see`
		288	`ftp://ftp.netcom.com/pub/hb/hbaker/NoMotionGC.html or the Jones and`
		289	`Lins GC book. The linked lists are implemented by adding two`
		290	`pointer fields to the SEXPREC structure, which increases its size`
		291	`from 5 to 7 words. Other approaches are possible but don't seem`
		292	`worth pursuing for R.`
		293
		294	`There are two options for dealing with old-to-new pointers. The`
		295	`first option is to make sure they never occur by transferring all`
		296	`referenced younger objects to the generation of the referrer when a`
		297	`reference to a newer object is assigned to an older one. This is`
		298	`enabled by defining EXPEL_OLD_TO_NEW. The second alternative is to`
		299	`keep track of all nodes that may contain references to newer nodes`
		300	`and to "age" the nodes they refer to at the beginning of each`
		301	`collection. This is the default. The first option is simpler in`
		302	`some ways, but will create more floating garbage and add a bit to`
		303	`the execution time, though the difference is probably marginal on`
		304	`both counts.*/`
		305	`/#define EXPEL_OLD_TO_NEW/`
		306	`static struct {`
11116	ripley	307	`SEXP Old[NUM_OLD_GENERATIONS], New, Free;`
		308	`SEXPREC OldPeg[NUM_OLD_GENERATIONS], NewPeg;`
10172	luke	309	`#ifndef EXPEL_OLD_TO_NEW`
11116	ripley	310	`SEXP OldToNew[NUM_OLD_GENERATIONS];`
		311	`SEXPREC OldToNewPeg[NUM_OLD_GENERATIONS];`
10172	luke	312	`#endif`
11116	ripley	313	`int OldCount[NUM_OLD_GENERATIONS], AllocCount, PageCount;`
		314	`PAGE_HEADER *pages;`
10172	luke	315	`} R_GenHeap[NUM_NODE_CLASSES];`
		316
20094	ripley	317	`static R_size_t R_NodesInUse = 0;`
10172	luke	318
		319	`#define NEXT_NODE(s) (s)->gengc_next_node`
		320	`#define PREV_NODE(s) (s)->gengc_prev_node`
		321	`#define SET_NEXT_NODE(s,t) (NEXT_NODE(s) = (t))`
		322	`#define SET_PREV_NODE(s,t) (PREV_NODE(s) = (t))`
		323
		324
		325	`/* Node List Manipulation */`
		326
		327	`/* unsnap node s from its list */`
		328	`#define UNSNAP_NODE(s) do { \`
		329	`SEXP un__n__ = (s); \`
		330	`SEXP next = NEXT_NODE(un__n__); \`
		331	`SEXP prev = PREV_NODE(un__n__); \`
		332	`SET_NEXT_NODE(prev, next); \`
		333	`SET_PREV_NODE(next, prev); \`
		334	`} while(0)`
		335
		336	`/* snap in node s before node t */`
		337	`#define SNAP_NODE(s,t) do { \`
		338	`SEXP sn__n__ = (s); \`
		339	`SEXP next = (t); \`
		340	`SEXP prev = PREV_NODE(next); \`
		341	`SET_NEXT_NODE(sn__n__, next); \`
		342	`SET_PREV_NODE(next, sn__n__); \`
		343	`SET_NEXT_NODE(prev, sn__n__); \`
		344	`SET_PREV_NODE(sn__n__, prev); \`
		345	`} while (0)`
		346
		347	`/* move all nodes on from_peg to to_peg */`
		348	`#define BULK_MOVE(from_peg,to_peg) do { \`
		349	`SEXP __from__ = (from_peg); \`
		350	`SEXP __to__ = (to_peg); \`
		351	`SEXP first_old = NEXT_NODE(__from__); \`
		352	`SEXP last_old = PREV_NODE(__from__); \`
		353	`SEXP first_new = NEXT_NODE(__to__); \`
		354	`SET_PREV_NODE(first_old, __to__); \`
		355	`SET_NEXT_NODE(__to__, first_old); \`
		356	`SET_PREV_NODE(first_new, last_old); \`
		357	`SET_NEXT_NODE(last_old, first_new); \`
		358	`SET_NEXT_NODE(__from__, __from__); \`
		359	`SET_PREV_NODE(__from__, __from__); \`
		360	`} while (0);`
		361
		362
		363	`/* Processing Node Children */`
		364
		365	`/* This macro calls dc__action__ for each child of __n__, passing`
		366	`dc__extra__ as a second argument for each call. */`
		367	`#define DO_CHILDREN(__n__,dc__action__,dc__extra__) do { \`
		368	`if (ATTRIB(__n__) != R_NilValue) \`
		369	`dc__action__(ATTRIB(__n__), dc__extra__); \`
		370	`switch (TYPEOF(__n__)) { \`
		371	`case NILSXP: \`
		372	`case BUILTINSXP: \`
		373	`case SPECIALSXP: \`
		374	`case CHARSXP: \`
		375	`case LGLSXP: \`
		376	`case INTSXP: \`
		377	`case REALSXP: \`
		378	`case CPLXSXP: \`
15928	luke	379	`case WEAKREFSXP: \`
10172	luke	380	`break; \`
		381	`case STRSXP: \`
		382	`case EXPRSXP: \`
		383	`case VECSXP: \`
		384	`{ \`
		385	`int i; \`
		386	`for (i = 0; i < LENGTH(__n__); i++) \`
		387	`dc__action__(STRING_ELT(__n__, i), dc__extra__); \`
		388	`} \`
		389	`break; \`
		390	`case ENVSXP: \`
		391	`dc__action__(FRAME(__n__), dc__extra__); \`
		392	`dc__action__(ENCLOS(__n__), dc__extra__); \`
		393	`dc__action__(HASHTAB(__n__), dc__extra__); \`
		394	`break; \`
		395	`case CLOSXP: \`
		396	`case PROMSXP: \`
		397	`case LISTSXP: \`
		398	`case LANGSXP: \`
		399	`case DOTSXP: \`
		400	`case SYMSXP: \`
26045	luke	401	`case BCODESXP: \`
10172	luke	402	`dc__action__(TAG(__n__), dc__extra__); \`
		403	`dc__action__(CAR(__n__), dc__extra__); \`
		404	`dc__action__(CDR(__n__), dc__extra__); \`
		405	`break; \`
11390	luke	406	`case EXTPTRSXP: \`
		407	`dc__action__(EXTPTR_PROT(__n__), dc__extra__); \`
		408	`dc__action__(EXTPTR_TAG(__n__), dc__extra__); \`
		409	`break; \`
10172	luke	410	`default: \`
		411	`abort(); \`
		412	`} \`
		413	`} while(0)`
		414
		415
		416	`/* Forwarding Nodes. These macros mark nodes or chindren of nodes and`
		417	`place them on the forwarding list. The forwarding list is assumed`
		418	`to be in a local variable of the caller named named`
		419	`forwarded_nodes. */`
		420
		421	`#define FORWARD_NODE(s) do { \`
		422	`SEXP fn__n__ = (s); \`
		423	`if (fn__n__ && ! NODE_IS_MARKED(fn__n__)) { \`
		424	`MARK_NODE(fn__n__); \`
		425	`UNSNAP_NODE(fn__n__); \`
		426	`SET_NEXT_NODE(fn__n__, forwarded_nodes); \`
		427	`forwarded_nodes = fn__n__; \`
		428	`} \`
		429	`} while (0)`
		430
		431	`#define FC_FORWARD_NODE(__n__,__dummy__) FORWARD_NODE(__n__)`
		432	`#define FORWARD_CHILDREN(__n__) DO_CHILDREN(__n__,FC_FORWARD_NODE, 0)`
		433
		434
		435	`/* Node Allocation. */`
		436
		437	`#define CLASS_GET_FREE_NODE(c,s) do { \`
		438	`SEXP __n__ = R_GenHeap[c].Free; \`
		439	`if (__n__ == R_GenHeap[c].New) { \`
		440	`GetNewPage(c); \`
		441	`__n__ = R_GenHeap[c].Free; \`
		442	`} \`
		443	`R_GenHeap[c].Free = NEXT_NODE(__n__); \`
		444	`R_NodesInUse++; \`
		445	`(s) = __n__; \`
		446	`} while (0)`
		447
		448	`#define NO_FREE_NODES() (R_NodesInUse >= R_NSize)`
		449	`#define GET_FREE_NODE(s) CLASS_GET_FREE_NODE(0,s)`
		450
		451
		452	`/* Debugging Routines. */`
		453
		454	`#ifdef DEBUG_GC`
		455	`static void CheckNodeGeneration(SEXP x, int g)`
		456	`{`
11116	ripley	457	`if (NODE_GENERATION(x) < g) {`
		458	`REprintf("untraced old-to-new reference\n");`
		459	`}`
10172	luke	460	`}`
		461
		462	`static void DEBUG_CHECK_NODE_COUNTS(char *where)`
		463	`{`
11116	ripley	464	`int i, OldCount, NewCount, OldToNewCount, gen;`
		465	`SEXP s;`
10172	luke	466
11116	ripley	467	`REprintf("Node counts %s:\n", where);`
		468	`for (i = 0; i < NUM_NODE_CLASSES; i++) {`
		469	`for (s = NEXT_NODE(R_GenHeap[i].New), NewCount = 0;`
		470	`s != R_GenHeap[i].New;`
		471	`s = NEXT_NODE(s)) {`
		472	`NewCount++;`
		473	`if (i != NODE_CLASS(s))`
		474	`REprintf("Inconsistent class assignment for node!\n");`
		475	`}`
		476	`for (gen = 0, OldCount = 0, OldToNewCount = 0;`
		477	`gen < NUM_OLD_GENERATIONS;`
		478	`gen++) {`
		479	`for (s = NEXT_NODE(R_GenHeap[i].Old[gen]);`
		480	`s != R_GenHeap[i].Old[gen];`
		481	`s = NEXT_NODE(s)) {`
		482	`OldCount++;`
		483	`if (i != NODE_CLASS(s))`
		484	`REprintf("Inconsistent class assignment for node!\n");`
		485	`if (gen != NODE_GENERATION(s))`
		486	`REprintf("Inconsistent node generation\n");`
		487	`DO_CHILDREN(s, CheckNodeGeneration, gen);`
		488	`}`
		489	`for (s = NEXT_NODE(R_GenHeap[i].OldToNew[gen]);`
		490	`s != R_GenHeap[i].OldToNew[gen];`
		491	`s = NEXT_NODE(s)) {`
		492	`OldToNewCount++;`
		493	`if (i != NODE_CLASS(s))`
		494	`REprintf("Inconsistent class assignment for node!\n");`
		495	`if (gen != NODE_GENERATION(s))`
		496	`REprintf("Inconsistent node generation\n");`
		497	`}`
		498	`}`
		499	`REprintf("Class: %d, New = %d, Old = %d, OldToNew = %d, Total = %d\n",`
		500	`i,`
		501	`NewCount, OldCount, OldToNewCount,`
		502	`NewCount + OldCount + OldToNewCount);`
10172	luke	503	`}`
		504	`}`
		505
		506	`static void DEBUG_GC_SUMMARY(int full_gc)`
		507	`{`
11116	ripley	508	`int i, gen, OldCount;`
20094	ripley	509	`REprintf("\n%s, VSize = %lu", full_gc ? "Full" : "Minor",`
11116	ripley	510	`R_SmallVallocSize + R_LargeVallocSize);`
		511	`for (i = 1; i < NUM_NODE_CLASSES; i++) {`
		512	`for (gen = 0, OldCount = 0; gen < NUM_OLD_GENERATIONS; gen++)`
		513	`OldCount += R_GenHeap[i].OldCount[gen];`
		514	`REprintf(", class %d: %d", i, OldCount);`
		515	`}`
10172	luke	516	`}`
		517	`#else`
		518	`#define DEBUG_CHECK_NODE_COUNTS(s)`
		519	`#define DEBUG_GC_SUMMARY(x)`
11116	ripley	520	`#endif /* DEBUG_GC */`
10172	luke	521
		522	`#ifdef DEBUG_ADJUST_HEAP`
		523	`static void DEBUG_ADJUST_HEAP_PRINT(double node_occup, double vect_occup)`
		524	`{`
11116	ripley	525	`int i;`
20094	ripley	526	`R_size_t alloc;`
11116	ripley	527	`REprintf("Node occupancy: %.0f%%\nVector occupancy: %.0f%%\n",`
		528	`100.0 * node_occup, 100.0 * vect_occup);`
		529	`alloc = R_LargeVallocSize +`
		530	`sizeof(SEXPREC_ALIGN) * R_GenHeap[LARGE_NODE_CLASS].AllocCount;`
		531	`for (i = 0; i < NUM_SMALL_NODE_CLASSES; i++)`
		532	`alloc += R_PAGE_SIZE * R_GenHeap[i].PageCount;`
20094	ripley	533	`REprintf("Total allocation: %lu\n", alloc);`
		534	`REprintf("Ncells %lu\nVcells %lu\n", R_NSize, R_VSize);`
10172	luke	535	`}`
		536	`#else`
		537	`#define DEBUG_ADJUST_HEAP_PRINT(node_occup, vect_occup)`
11116	ripley	538	`#endif /* DEBUG_ADJUST_HEAP */`
10172	luke	539
11116	ripley	540	`#ifdef DEBUG_RELEASE_MEM`
10172	luke	541	`static void DEBUG_RELEASE_PRINT(int rel_pages, int maxrel_pages, int i)`
		542	`{`
11116	ripley	543	`if (maxrel_pages > 0) {`
		544	`int gen, n;`
		545	`REprintf("Class: %d, pages = %d, maxrel = %d, released = %d\n", i,`
		546	`R_GenHeap[i].PageCount, maxrel_pages, rel_pages);`
		547	`for (gen = 0, n = 0; gen < NUM_OLD_GENERATIONS; gen++)`
		548	`n += R_GenHeap[i].OldCount[gen];`
		549	`REprintf("Allocated = %d, in use = %d\n", R_GenHeap[i].AllocCount, n);`
		550	`}`
10172	luke	551	`}`
		552	`#else`
		553	`#define DEBUG_RELEASE_PRINT(rel_pages, maxrel_pages, i)`
11116	ripley	554	`#endif /* DEBUG_RELEASE_MEM */`
10172	luke	555
		556
		557	`/* Page Allocation and Release. */`
		558
		559	`static void GetNewPage(int node_class)`
		560	`{`
11116	ripley	561	`SEXP s, base;`
		562	`char *data;`
		563	`PAGE_HEADER *page;`
		564	`int node_size, page_count, i;`
10172	luke	565
11116	ripley	566	`node_size = NODE_SIZE(node_class);`
		567	`page_count = (R_PAGE_SIZE - sizeof(PAGE_HEADER)) / node_size;`
10407	maechler	568
11116	ripley	569	`page = malloc(R_PAGE_SIZE);`
		570	`if (page == NULL)`
20094	ripley	571	`mem_err_heap((R_size_t) NodeClassSize[node_class]);`
11116	ripley	572	`page->next = R_GenHeap[node_class].pages;`
		573	`R_GenHeap[node_class].pages = page;`
		574	`R_GenHeap[node_class].PageCount++;`
10172	luke	575
11116	ripley	576	`data = PAGE_DATA(page);`
		577	`base = R_GenHeap[node_class].New;`
		578	`for (i = 0; i < page_count; i++, data += node_size) {`
		579	`s = (SEXP) data;`
		580	`R_GenHeap[node_class].AllocCount++;`
		581	`SNAP_NODE(s, base);`
		582	`s->sxpinfo = UnmarkedNodeTemplate.sxpinfo;`
		583	`SET_NODE_CLASS(s, node_class);`
		584	`base = s;`
		585	`R_GenHeap[node_class].Free = s;`
		586	`}`
10172	luke	587	`}`
		588
		589	`static void ReleasePage(PAGE_HEADER *page, int node_class)`
		590	`{`
11116	ripley	591	`SEXP s;`
		592	`char *data;`
		593	`int node_size, page_count, i;`
10172	luke	594
11116	ripley	595	`node_size = NODE_SIZE(node_class);`
		596	`page_count = (R_PAGE_SIZE - sizeof(PAGE_HEADER)) / node_size;`
		597	`data = PAGE_DATA(page);`
10172	luke	598
11116	ripley	599	`for (i = 0; i < page_count; i++, data += node_size) {`
		600	`s = (SEXP) data;`
		601	`UNSNAP_NODE(s);`
		602	`R_GenHeap[node_class].AllocCount--;`
		603	`}`
		604	`R_GenHeap[node_class].PageCount--;`
		605	`free(page);`
10172	luke	606	`}`
		607
		608	`static void TryToReleasePages(void)`
		609	`{`
11116	ripley	610	`SEXP s;`
		611	`int i;`
		612	`static int release_count = 0;`
10172	luke	613
11116	ripley	614	`if (release_count == 0) {`
		615	`release_count = R_PageReleaseFreq;`
		616	`for (i = 0; i < NUM_SMALL_NODE_CLASSES; i++) {`
		617	`int pages_free = 0;`
		618	`PAGE_HEADER page, last, *next;`
		619	`int node_size = NODE_SIZE(i);`
		620	`int page_count = (R_PAGE_SIZE - sizeof(PAGE_HEADER)) / node_size;`
		621	`int maxrel, maxrel_pages, rel_pages, gen;`
10172	luke	622
11116	ripley	623	`maxrel = R_GenHeap[i].AllocCount;`
		624	`for (gen = 0; gen < NUM_OLD_GENERATIONS; gen++)`
		625	`maxrel -= (1.0 + R_MaxKeepFrac) * R_GenHeap[i].OldCount[gen];`
		626	`maxrel_pages = maxrel > 0 ? maxrel / page_count : 0;`
10407	maechler	627
11116	ripley	628	`/* all nodes in New space should be both free and unmarked */`
		629	`for (page = R_GenHeap[i].pages, rel_pages = 0, last = NULL;`
		630	`rel_pages < maxrel_pages && page != NULL;) {`
		631	`int j, in_use;`
		632	`char *data = PAGE_DATA(page);`
10172	luke	633
11116	ripley	634	`next = page->next;`
11197	ripley	635	`for (in_use = 0, j = 0; j < page_count;`
11116	ripley	636	`j++, data += node_size) {`
		637	`s = (SEXP) data;`
		638	`if (NODE_IS_MARKED(s)) {`
		639	`in_use = 1;`
		640	`break;`
		641	`}`
		642	`}`
		643	`if (! in_use) {`
		644	`ReleasePage(page, i);`
		645	`if (last == NULL)`
		646	`R_GenHeap[i].pages = next;`
		647	`else`
		648	`last->next = next;`
		649	`pages_free++;`
		650	`rel_pages++;`
		651	`}`
		652	`else last = page;`
		653	`page = next;`
		654	`}`
		655	`DEBUG_RELEASE_PRINT(rel_pages, maxrel_pages, i);`
		656	`R_GenHeap[i].Free = NEXT_NODE(R_GenHeap[i].New);`
10172	luke	657	`}`
		658	`}`
11116	ripley	659	`else release_count--;`
10172	luke	660	`}`
		661
		662	`static void ReleaseLargeFreeVectors(void)`
		663	`{`
11116	ripley	664	`SEXP s = NEXT_NODE(R_GenHeap[LARGE_NODE_CLASS].New);`
		665	`while (s != R_GenHeap[LARGE_NODE_CLASS].New) {`
		666	`SEXP next = NEXT_NODE(s);`
		667	`if (CHAR(s) != NULL) {`
20094	ripley	668	`R_size_t size;`
11116	ripley	669	`switch (TYPEOF(s)) { /* get size in bytes */`
		670	`case CHARSXP:`
		671	`size = LENGTH(s) + 1;`
		672	`break;`
		673	`case LGLSXP:`
		674	`case INTSXP:`
		675	`size = LENGTH(s) * sizeof(int);`
		676	`break;`
		677	`case REALSXP:`
		678	`size = LENGTH(s) * sizeof(double);`
		679	`break;`
		680	`case CPLXSXP:`
		681	`size = LENGTH(s) * sizeof(Rcomplex);`
		682	`break;`
		683	`case STRSXP:`
		684	`case EXPRSXP:`
		685	`case VECSXP:`
		686	`size = LENGTH(s) * sizeof(SEXP);`
		687	`break;`
		688	`default:`
		689	`abort();`
		690	`}`
		691	`size = BYTE2VEC(size);`
		692	`UNSNAP_NODE(s);`
		693	`R_LargeVallocSize -= size;`
		694	`R_GenHeap[LARGE_NODE_CLASS].AllocCount--;`
		695	`free(s);`
		696	`}`
		697	`s = next;`
10172	luke	698	`}`
		699	`}`
		700
		701
		702	`/* Heap Size Adjustment. */`
		703
20094	ripley	704	`static void AdjustHeapSize(R_size_t size_needed)`
10172	luke	705	`{`
20094	ripley	706	`R_size_t R_MinNFree = orig_R_NSize * R_MinFreeFrac;`
		707	`R_size_t R_MinVFree = orig_R_VSize * R_MinFreeFrac;`
		708	`R_size_t NNeeded = R_NodesInUse + R_MinNFree;`
		709	`R_size_t VNeeded = R_SmallVallocSize + R_LargeVallocSize`
11135	luke	710	`+ size_needed + R_MinVFree;`
		711	`double node_occup = ((double) NNeeded) / R_NSize;`
		712	`double vect_occup = ((double) VNeeded) / R_VSize;`
10172	luke	713
11116	ripley	714	`if (node_occup > R_NGrowFrac) {`
20094	ripley	715	`R_size_t change = R_NGrowIncrMin + R_NGrowIncrFrac * R_NSize;`
		716	`if (R_MaxNSize >= R_NSize + change)`
11135	luke	717	`R_NSize += change;`
11116	ripley	718	`}`
		719	`else if (node_occup < R_NShrinkFrac) {`
20094	ripley	720	`R_NSize -= (R_NShrinkIncrMin + R_NShrinkIncrFrac * R_NSize);`
11135	luke	721	`if (R_NSize < NNeeded)`
11197	ripley	722	`R_NSize = (NNeeded < R_MaxNSize) ? NNeeded: R_MaxNSize;`
11116	ripley	723	`if (R_NSize < orig_R_NSize)`
		724	`R_NSize = orig_R_NSize;`
		725	`}`
10172	luke	726
11297	luke	727	`if (vect_occup > 1.0 && VNeeded < R_MaxVSize)`
		728	`R_VSize = VNeeded;`
11135	luke	729	`if (vect_occup > R_VGrowFrac) {`
20094	ripley	730	`R_size_t change = R_VGrowIncrMin + R_VGrowIncrFrac * R_NSize;`
11135	luke	731	`if (R_MaxVSize - R_VSize >= change)`
		732	`R_VSize += change;`
11116	ripley	733	`}`
		734	`else if (vect_occup < R_VShrinkFrac) {`
11135	luke	735	`R_VSize -= R_VShrinkIncrMin + R_VShrinkIncrFrac * R_VSize;`
		736	`if (R_VSize < VNeeded)`
		737	`R_VSize = VNeeded;`
11116	ripley	738	`if (R_VSize < orig_R_VSize)`
		739	`R_VSize = orig_R_VSize;`
		740	`}`
10172	luke	741
11116	ripley	742	`DEBUG_ADJUST_HEAP_PRINT(node_occup, vect_occup);`
10172	luke	743	`}`
		744
		745
		746	`/* Managing Old-to-New References. */`
		747
		748	`#define AGE_NODE(s,g) do { \`
		749	`SEXP an__n__ = (s); \`
		750	`int an__g__ = (g); \`
		751	`if (an__n__ && NODE_GEN_IS_YOUNGER(an__n__, an__g__)) { \`
		752	`if (NODE_IS_MARKED(an__n__)) \`
		753	`R_GenHeap[NODE_CLASS(an__n__)].OldCount[NODE_GENERATION(an__n__)]--; \`
		754	`else \`
		755	`MARK_NODE(an__n__); \`
		756	`SET_NODE_GENERATION(an__n__, an__g__); \`
		757	`UNSNAP_NODE(an__n__); \`
		758	`SET_NEXT_NODE(an__n__, forwarded_nodes); \`
		759	`forwarded_nodes = an__n__; \`
		760	`} \`
		761	`} while (0)`
		762
		763	`static void AgeNodeAndChildren(SEXP s, int gen)`
		764	`{`
11116	ripley	765	`SEXP forwarded_nodes = NULL;`
		766	`AGE_NODE(s, gen);`
		767	`while (forwarded_nodes != NULL) {`
13600	maechler	768	`s = forwarded_nodes;`
11116	ripley	769	`forwarded_nodes = NEXT_NODE(forwarded_nodes);`
		770	`if (NODE_GENERATION(s) != gen)`
		771	`REprintf("****snapping into wrong generation\n");`
		772	`SNAP_NODE(s, R_GenHeap[NODE_CLASS(s)].Old[gen]);`
		773	`R_GenHeap[NODE_CLASS(s)].OldCount[gen]++;`
		774	`DO_CHILDREN(s, AGE_NODE, gen);`
		775	`}`
10172	luke	776	`}`
		777
		778	`static void old_to_new(SEXP x, SEXP y)`
		779	`{`
		780	`#ifdef EXPEL_OLD_TO_NEW`
11116	ripley	781	`AgeNodeAndChildren(y, NODE_GENERATION(x));`
10172	luke	782	`#else`
11116	ripley	783	`UNSNAP_NODE(x);`
		784	`SNAP_NODE(x, R_GenHeap[NODE_CLASS(x)].OldToNew[NODE_GENERATION(x)]);`
10172	luke	785	`#endif`
		786	`}`
		787
		788	`#define CHECK_OLD_TO_NEW(x,y) do { \`
		789	`if (NODE_IS_OLDER(x, y)) old_to_new(x,y); } while (0)`
		790
		791
10930	luke	792	`/* Node Sorting. SortNodes attempts to improve locality of reference`
11116	ripley	793	`by rearranging the free list to place nodes on the same place page`
		794	`together and order nodes within pages. This involves a sweep of the`
		795	`heap, so it should not be done too often, but doing it at least`
		796	`occasionally does seem essential. Sorting on each full colllection is`
11197	ripley	797	`probably sufficient.`
11116	ripley	798	`*/`
		799
10930	luke	800	`#define SORT_NODES`
10172	luke	801	`#ifdef SORT_NODES`
		802	`static void SortNodes(void)`
		803	`{`
11116	ripley	804	`SEXP s;`
		805	`int i;`
10172	luke	806
11116	ripley	807	`for (i = 0; i < NUM_SMALL_NODE_CLASSES; i++) {`
		808	`PAGE_HEADER *page;`
		809	`int node_size = NODE_SIZE(i);`
		810	`int page_count = (R_PAGE_SIZE - sizeof(PAGE_HEADER)) / node_size;`
10172	luke	811
11116	ripley	812	`SET_NEXT_NODE(R_GenHeap[i].New, R_GenHeap[i].New);`
		813	`SET_PREV_NODE(R_GenHeap[i].New, R_GenHeap[i].New);`
		814	`for (page = R_GenHeap[i].pages; page != NULL; page = page->next) {`
		815	`int j;`
		816	`char *data = PAGE_DATA(page);`
10172	luke	817
11116	ripley	818	`for (j = 0; j < page_count; j++, data += node_size) {`
		819	`s = (SEXP) data;`
		820	`if (! NODE_IS_MARKED(s))`
		821	`SNAP_NODE(s, R_GenHeap[i].New);`
		822	`}`
		823	`}`
		824	`R_GenHeap[i].Free = NEXT_NODE(R_GenHeap[i].New);`
10172	luke	825	`}`
		826	`}`
		827	`#endif`
		828
		829
15915	luke	830	`/* Finalization and Weak References */`
11390	luke	831
15929	luke	832	`/* The design of this mechanism is very close to the one described in`
		833	`"Stretching the storage manager: weak pointers and stable names in`
		834	`Haskell" by Peyton Jones, Marlow, and Elliott (at`
		835	`www.research.microsoft.com/Users/simonpj/papers/weak.ps.gz). --LT */`
		836
15915	luke	837	`static SEXP R_weak_refs = NULL;`
11390	luke	838
15883	luke	839	`#define READY_TO_FINALIZE_MASK 1`
15882	luke	840
15883	luke	841	`#define SET_READY_TO_FINALIZE(s) ((s)->sxpinfo.gp \|= READY_TO_FINALIZE_MASK)`
		842	`#define CLEAR_READY_TO_FINALIZE(s) ((s)->sxpinfo.gp &= ~READY_TO_FINALIZE_MASK)`
		843	`#define IS_READY_TO_FINALIZE(s) ((s)->sxpinfo.gp & READY_TO_FINALIZE_MASK)`
		844
15884	luke	845	`#define FINALIZE_ON_EXIT_MASK 2`
		846
		847	`#define SET_FINALIZE_ON_EXIT(s) ((s)->sxpinfo.gp \|= FINALIZE_ON_EXIT_MASK)`
		848	`#define CLEAR_FINALIZE_ON_EXIT(s) ((s)->sxpinfo.gp &= ~FINALIZE_ON_EXIT_MASK)`
		849	`#define FINALIZE_ON_EXIT(s) ((s)->sxpinfo.gp & FINALIZE_ON_EXIT_MASK)`
		850
15928	luke	851	`#define WEAKREF_SIZE 4`
		852	`#define WEAKREF_KEY(w) VECTOR_ELT(w, 0)`
		853	`#define SET_WEAKREF_KEY(w, k) SET_VECTOR_ELT(w, 0, k)`
		854	`#define WEAKREF_VALUE(w) VECTOR_ELT(w, 1)`
		855	`#define SET_WEAKREF_VALUE(w, v) SET_VECTOR_ELT(w, 1, v)`
		856	`#define WEAKREF_FINALIZER(w) VECTOR_ELT(w, 2)`
		857	`#define SET_WEAKREF_FINALIZER(w, f) SET_VECTOR_ELT(w, 2, f)`
		858	`#define WEAKREF_NEXT(w) VECTOR_ELT(w, 3)`
		859	`#define SET_WEAKREF_NEXT(w, n) SET_VECTOR_ELT(w, 3, n)`
15915	luke	860
15928	luke	861	`static SEXP MakeCFinalizer(R_CFinalizer_t cfun);`
		862
15915	luke	863	`static SEXP NewWeakRef(SEXP key, SEXP val, SEXP fin, Rboolean onexit)`
		864	`{`
		865	`SEXP w;`
		866
		867	`switch (TYPEOF(key)) {`
15928	luke	868	`case NILSXP:`
15915	luke	869	`case ENVSXP:`
		870	`case EXTPTRSXP:`
		871	`break;`
		872	`default: error("can only weakly reference/finalize reference objects");`
		873	`}`
		874
15928	luke	875	`PROTECT(key);`
		876	`PROTECT(val = NAMED(val) ? duplicate(val) : val);`
		877	`PROTECT(fin);`
		878	`w = allocVector(VECSXP, WEAKREF_SIZE);`
		879	`SET_TYPEOF(w, WEAKREFSXP);`
		880	`if (key != R_NilValue) {`
		881	`/* If the key is R_NilValue we don't register the weak reference.`
		882	`This is used in loading saved images. */`
		883	`SET_WEAKREF_KEY(w, key);`
		884	`SET_WEAKREF_VALUE(w, val);`
		885	`SET_WEAKREF_FINALIZER(w, fin);`
		886	`SET_WEAKREF_NEXT(w, R_weak_refs);`
		887	`CLEAR_READY_TO_FINALIZE(w);`
		888	`if (onexit)`
		889	`SET_FINALIZE_ON_EXIT(w);`
		890	`else`
		891	`CLEAR_FINALIZE_ON_EXIT(w);`
		892	`R_weak_refs = w;`
		893	`}`
		894	`UNPROTECT(3);`
		895	`return w;`
		896	`}`
		897
		898	`SEXP R_MakeWeakRef(SEXP key, SEXP val, SEXP fin, Rboolean onexit)`
		899	`{`
		900	`switch (TYPEOF(fin)) {`
		901	`case NILSXP:`
		902	`case CLOSXP:`
		903	`case BUILTINSXP:`
		904	`case SPECIALSXP:`
		905	`break;`
		906	`default: error("finalizer must be a function or NULL");`
		907	`}`
		908	`return NewWeakRef(key, val, fin, onexit);`
		909	`}`
		910
		911	`SEXP R_MakeWeakRefC(SEXP key, SEXP val, R_CFinalizer_t fin, Rboolean onexit)`
		912	`{`
		913	`SEXP w;`
		914	`PROTECT(key);`
15915	luke	915	`PROTECT(val);`
15928	luke	916	`w = NewWeakRef(key, val, MakeCFinalizer(fin), onexit);`
15915	luke	917	`UNPROTECT(2);`
		918	`return w;`
		919	`}`
		920
11390	luke	921	`static void CheckFinalizers(void)`
		922	`{`
		923	`SEXP s;`
15915	luke	924	`for (s = R_weak_refs; s != R_NilValue; s = WEAKREF_NEXT(s))`
15928	luke	925	`if (! NODE_IS_MARKED(WEAKREF_KEY(s)) && ! IS_READY_TO_FINALIZE(s))`
15882	luke	926	`SET_READY_TO_FINALIZE(s);`
11390	luke	927	`}`
		928
11834	luke	929	`/* C finalizers are stored in a CHARSXP. It would be nice if we could`
		930	`use EXTPTRSXP's but these only hold a void *, and function pointers`
		931	`are not guaranteed to be compatible with a void *. There should be`
15929	luke	932	`a cleaner way of doing this, but this will do for now. --LT */`
11834	luke	933	`static Rboolean isCFinalizer(SEXP fun)`
		934	`{`
		935	`return TYPEOF(fun) == CHARSXP;`
		936	`/return TYPEOF(fun) == EXTPTRSXP;/`
		937	`}`
		938
		939	`static SEXP MakeCFinalizer(R_CFinalizer_t cfun)`
		940	`{`
		941	`SEXP s = allocString(sizeof(R_CFinalizer_t));`
		942	`((R_CFinalizer_t ) CHAR(s)) = cfun;`
		943	`return s;`
		944	`/return R_MakeExternalPtr((void ) cfun, R_NilValue, R_NilValue);*/`
		945	`}`
		946
		947	`static R_CFinalizer_t GetCFinalizer(SEXP fun)`
		948	`{`
		949	`return ((R_CFinalizer_t ) CHAR(fun));`
		950	`/return (R_CFinalizer_t) R_ExternalPtrAddr(fun);/`
		951	`}`
		952
15928	luke	953	`SEXP R_WeakRefKey(SEXP w)`
		954	`{`
		955	`if (TYPEOF(w) != WEAKREFSXP)`
		956	`error("not a weak reference");`
		957	`return WEAKREF_KEY(w);`
		958	`}`
		959
		960	`SEXP R_WeakRefValue(SEXP w)`
		961	`{`
		962	`SEXP v;`
		963	`if (TYPEOF(w) != WEAKREFSXP)`
		964	`error("not a weak reference");`
		965	`v = WEAKREF_VALUE(w);`
		966	`if (v != R_NilValue && NAMED(v) != 2)`
		967	`SET_NAMED(v, 2);`
		968	`return v;`
		969	`}`
		970
		971	`void R_RunWeakRefFinalizer(SEXP w)`
		972	`{`
		973	`SEXP key, fun, e;`
		974	`if (TYPEOF(w) != WEAKREFSXP)`
		975	`error("not a weak reference");`
		976	`key = WEAKREF_KEY(w);`
		977	`fun = WEAKREF_FINALIZER(w);`
		978	`SET_WEAKREF_KEY(w, R_NilValue);`
		979	`SET_WEAKREF_VALUE(w, R_NilValue);`
		980	`SET_WEAKREF_FINALIZER(w, R_NilValue);`
		981	`if (! IS_READY_TO_FINALIZE(w))`
		982	`SET_READY_TO_FINALIZE(w); /* insures removal from list on next gc */`
		983	`PROTECT(key);`
		984	`PROTECT(fun);`
		985	`if (isCFinalizer(fun)) {`
		986	`/* Must be a C finalizer. */`
		987	`R_CFinalizer_t cfun = GetCFinalizer(fun);`
		988	`cfun(key);`
		989	`}`
		990	`else if (fun != R_NilValue) {`
		991	`/* An R finalizer. */`
		992	`PROTECT(e = LCONS(fun, LCONS(key, R_NilValue)));`
		993	`eval(e, R_GlobalEnv);`
		994	`UNPROTECT(1);`
		995	`}`
		996	`UNPROTECT(2);`
		997	`}`
		998
11390	luke	999	`static Rboolean RunFinalizers(void)`
		1000	`{`
		1001	`volatile SEXP s, last;`
		1002	`volatile Rboolean finalizer_run = FALSE;`
		1003
15915	luke	1004	`for (s = R_weak_refs, last = R_NilValue; s != R_NilValue;) {`
		1005	`SEXP next = WEAKREF_NEXT(s);`
15882	luke	1006	`if (IS_READY_TO_FINALIZE(s)) {`
11390	luke	1007	`RCNTXT thiscontext;`
		1008	`RCNTXT * volatile saveToplevelContext;`
		1009	`volatile int savestack;`
		1010	`volatile SEXP topExp;`
		1011
		1012	`finalizer_run = TRUE;`
		1013
		1014	`/* A top level context is established for the finalizer to`
		1015	`insure that any errors that might occur do not spill`
		1016	`into the call that triggered the collection. */`
		1017	`begincontext(&thiscontext, CTXT_TOPLEVEL, R_NilValue, R_GlobalEnv,`
23463	luke	1018	`R_NilValue, R_NilValue, R_NilValue);`
11390	luke	1019	`saveToplevelContext = R_ToplevelContext;`
		1020	`PROTECT(topExp = R_CurrentExpr);`
		1021	`savestack = R_PPStackTop;`
		1022	`if (! SETJMP(thiscontext.cjmpbuf)) {`
		1023	`R_GlobalContext = R_ToplevelContext = &thiscontext;`
		1024
15928	luke	1025	`/* The entry in the weak reference list is removed`
11390	luke	1026	`before running the finalizer. This insures that a`
		1027	`finalizer is run only once, even if running it`
		1028	`raises an error. */`
		1029	`if (last == R_NilValue)`
15915	luke	1030	`R_weak_refs = next;`
11390	luke	1031	`else`
15928	luke	1032	`SET_WEAKREF_NEXT(last, next);`
		1033	`R_RunWeakRefFinalizer(s);`
11390	luke	1034	`}`
		1035	`endcontext(&thiscontext);`
		1036	`R_ToplevelContext = saveToplevelContext;`
		1037	`R_PPStackTop = savestack;`
		1038	`R_CurrentExpr = topExp;`
		1039	`UNPROTECT(1);`
		1040	`}`
		1041	`else last = s;`
		1042	`s = next;`
		1043	`}`
		1044	`return finalizer_run;`
		1045	`}`
		1046
15884	luke	1047	`void R_RunExitFinalizers(void)`
11390	luke	1048	`{`
15884	luke	1049	`SEXP s;`
		1050
15915	luke	1051	`for (s = R_weak_refs; s != R_NilValue; s = WEAKREF_NEXT(s))`
15884	luke	1052	`if (FINALIZE_ON_EXIT(s))`
		1053	`SET_READY_TO_FINALIZE(s);`
		1054	`RunFinalizers();`
		1055	`}`
		1056
		1057	`void R_RegisterFinalizerEx(SEXP s, SEXP fun, Rboolean onexit)`
		1058	`{`
15928	luke	1059	`R_MakeWeakRef(s, R_NilValue, fun, onexit);`
11390	luke	1060	`}`
		1061
15884	luke	1062	`void R_RegisterFinalizer(SEXP s, SEXP fun)`
11390	luke	1063	`{`
15884	luke	1064	`R_RegisterFinalizerEx(s, fun, FALSE);`
		1065	`}`
		1066
		1067	`void R_RegisterCFinalizerEx(SEXP s, R_CFinalizer_t fun, Rboolean onexit)`
		1068	`{`
15928	luke	1069	`R_MakeWeakRefC(s, R_NilValue, fun, onexit);`
11390	luke	1070	`}`
		1071
15884	luke	1072	`void R_RegisterCFinalizer(SEXP s, R_CFinalizer_t fun)`
		1073	`{`
		1074	`R_RegisterCFinalizerEx(s, fun, FALSE);`
		1075	`}`
		1076
16557	pd	1077	`/* R interface function */`
15884	luke	1078
16557	pd	1079	`SEXP do_regFinaliz(SEXP call, SEXP op, SEXP args, SEXP rho)`
		1080	`{`
		1081	`checkArity(op, args);`
		1082
		1083	`if (TYPEOF(CAR(args)) != ENVSXP && TYPEOF(CAR(args)) != EXTPTRSXP)`
		1084	`errorcall(call, "1st arg must be environment or external pointer");`
		1085	`if (TYPEOF(CADR(args)) != CLOSXP)`
		1086	`errorcall(call, "2nd arg must be a function");`
		1087
		1088	`R_RegisterFinalizer(CAR(args), CADR(args));`
		1089	`return R_NilValue;`
		1090	`}`
		1091
		1092
10172	luke	1093	`/* The Generational Collector. */`
		1094
11390	luke	1095	`#define PROCESS_NODES() do { \`
		1096	`while (forwarded_nodes != NULL) { \`
		1097	`s = forwarded_nodes; \`
		1098	`forwarded_nodes = NEXT_NODE(forwarded_nodes); \`
		1099	`SNAP_NODE(s, R_GenHeap[NODE_CLASS(s)].Old[NODE_GENERATION(s)]); \`
		1100	`R_GenHeap[NODE_CLASS(s)].OldCount[NODE_GENERATION(s)]++; \`
		1101	`FORWARD_CHILDREN(s); \`
		1102	`} \`
		1103	`} while (0)`
		1104
20094	ripley	1105	`static void RunGenCollect(R_size_t size_needed)`
10172	luke	1106	`{`
11116	ripley	1107	`int i, gen, gens_collected;`
		1108	`DevDesc *dd;`
		1109	`RCNTXT *ctxt;`
		1110	`SEXP s;`
		1111	`SEXP forwarded_nodes;`
10172	luke	1112
11116	ripley	1113	`/* determine number of generations to collect */`
		1114	`while (num_old_gens_to_collect < NUM_OLD_GENERATIONS) {`
		1115	`if (collect_counts[num_old_gens_to_collect]-- <= 0) {`
		1116	`collect_counts[num_old_gens_to_collect] =`
		1117	`collect_counts_max[num_old_gens_to_collect];`
		1118	`num_old_gens_to_collect++;`
		1119	`}`
		1120	`else break;`
10172	luke	1121	`}`
		1122
11116	ripley	1123	`again:`
		1124	`gens_collected = num_old_gens_to_collect;`
10172	luke	1125
		1126	`#ifndef EXPEL_OLD_TO_NEW`
11116	ripley	1127	`/* eliminate old-to-new references in generations to collect by`
		1128	`transferring referenced nodes to referring generation */`
		1129	`for (gen = 0; gen < num_old_gens_to_collect; gen++) {`
		1130	`for (i = 0; i < NUM_NODE_CLASSES; i++) {`
		1131	`s = NEXT_NODE(R_GenHeap[i].OldToNew[gen]);`
		1132	`while (s != R_GenHeap[i].OldToNew[gen]) {`
		1133	`SEXP next = NEXT_NODE(s);`
		1134	`DO_CHILDREN(s, AgeNodeAndChildren, gen);`
		1135	`UNSNAP_NODE(s);`
		1136	`if (NODE_GENERATION(s) != gen)`
		1137	`REprintf("****snapping into wrong generation\n");`
		1138	`SNAP_NODE(s, R_GenHeap[i].Old[gen]);`
		1139	`s = next;`
		1140	`}`
		1141	`}`
10172	luke	1142	`}`
		1143	`#endif`
		1144
11116	ripley	1145	`DEBUG_CHECK_NODE_COUNTS("at start");`
10172	luke	1146
11116	ripley	1147	`/* unmark all marked nodes in old generations to be collected and`
		1148	`move to New space */`
		1149	`for (gen = 0; gen < num_old_gens_to_collect; gen++) {`
		1150	`for (i = 0; i < NUM_NODE_CLASSES; i++) {`
		1151	`R_GenHeap[i].OldCount[gen] = 0;`
		1152	`s = NEXT_NODE(R_GenHeap[i].Old[gen]);`
		1153	`while (s != R_GenHeap[i].Old[gen]) {`
		1154	`SEXP next = NEXT_NODE(s);`
		1155	`if (gen < NUM_OLD_GENERATIONS - 1)`
		1156	`SET_NODE_GENERATION(s, gen + 1);`
		1157	`UNMARK_NODE(s);`
		1158	`s = next;`
		1159	`}`
		1160	`if (NEXT_NODE(R_GenHeap[i].Old[gen]) != R_GenHeap[i].Old[gen])`
		1161	`BULK_MOVE(R_GenHeap[i].Old[gen], R_GenHeap[i].New);`
		1162	`}`
10172	luke	1163	`}`
		1164
11116	ripley	1165	`forwarded_nodes = NULL;`
10172	luke	1166
		1167	`#ifndef EXPEL_OLD_TO_NEW`
11116	ripley	1168	`/* scan nodes in uncollected old generations with old-to-new pointers */`
		1169	`for (gen = num_old_gens_to_collect; gen < NUM_OLD_GENERATIONS; gen++)`
		1170	`for (i = 0; i < NUM_NODE_CLASSES; i++)`
		1171	`for (s = NEXT_NODE(R_GenHeap[i].OldToNew[gen]);`
		1172	`s != R_GenHeap[i].OldToNew[gen];`
		1173	`s = NEXT_NODE(s))`
		1174	`FORWARD_CHILDREN(s);`
10172	luke	1175	`#endif`
		1176
11116	ripley	1177	`/* forward all roots */`
		1178	`FORWARD_NODE(R_NilValue); /* Builtin constants */`
		1179	`FORWARD_NODE(NA_STRING);`
		1180	`FORWARD_NODE(R_BlankString);`
		1181	`FORWARD_NODE(R_UnboundValue);`
14906	luke	1182	`FORWARD_NODE(R_RestartToken);`
11116	ripley	1183	`FORWARD_NODE(R_MissingArg);`
		1184	`FORWARD_NODE(R_CommentSxp);`
10172	luke	1185
11116	ripley	1186	`FORWARD_NODE(R_GlobalEnv); /* Global environment */`
		1187	`FORWARD_NODE(R_Warnings); /* Warnings, if any */`
10172	luke	1188
25523	luke	1189	`#ifdef NEW_CONDITION_HANDLING`
		1190	`FORWARD_NODE(R_HandlerStack); /* Condition handler stack */`
		1191	`FORWARD_NODE(R_RestartStack); /* Available restarts stack */`
		1192	`#endif`
		1193
11116	ripley	1194	`for (i = 0; i < HSIZE; i++) /* Symbol table */`
		1195	`FORWARD_NODE(R_SymbolTable[i]);`
10172	luke	1196
11116	ripley	1197	`if (R_CurrentExpr != NULL) /* Current expression */`
		1198	`FORWARD_NODE(R_CurrentExpr);`
10172	luke	1199
11116	ripley	1200	`for (i = 0; i < R_MaxDevices; i++) { /* Device display lists */`
		1201	`dd = GetDevice(i);`
16910	ripley	1202	`if (dd) {`
18917	murrell	1203	`if (dd->newDevStruct) {`
16881	murrell	1204	`FORWARD_NODE(((GEDevDesc*) dd)->dev->displayList);`
18917	murrell	1205	`FORWARD_NODE(((GEDevDesc*) dd)->dev->savedSnapshot);`
		1206	`}`
16881	murrell	1207	`else`
		1208	`FORWARD_NODE(dd->displayList);`
16910	ripley	1209	`}`
11116	ripley	1210	`}`
10172	luke	1211
23463	luke	1212	`for (ctxt = R_GlobalContext ; ctxt != NULL ; ctxt = ctxt->nextcontext) {`
		1213	`FORWARD_NODE(ctxt->conexit); /* on.exit expressions */`
		1214	`FORWARD_NODE(ctxt->promargs); /* promises supplied to closure */`
		1215	`FORWARD_NODE(ctxt->callfun); /* the closure called */`
		1216	`FORWARD_NODE(ctxt->sysparent); /* calling environment */`
		1217	`FORWARD_NODE(ctxt->call); /* the call */`
		1218	`FORWARD_NODE(ctxt->cloenv); /* the closure environment */`
25523	luke	1219	`#ifdef NEW_CONDITION_HANDLING`
		1220	`FORWARD_NODE(ctxt->handlerstack); /* the condition handler stack */`
		1221	`FORWARD_NODE(ctxt->restartstack); /* the available restarts stack */`
		1222	`#endif`
23463	luke	1223	`}`
10172	luke	1224
11116	ripley	1225	`FORWARD_NODE(framenames); /* used for interprocedure`
		1226	`communication in model.c */`
10172	luke	1227
11116	ripley	1228	`FORWARD_NODE(R_PreciousList);`
10172	luke	1229
11116	ripley	1230	`for (i = 0; i < R_PPStackTop; i++) /* Protected pointers */`
		1231	`FORWARD_NODE(R_PPStack[i]);`
10172	luke	1232
11116	ripley	1233	`FORWARD_NODE(R_VStack); /* R_alloc stack */`
10172	luke	1234
26045	luke	1235	`#ifdef BYTECODE`
		1236	`{`
		1237	`SEXP *sp;`
		1238	`for (sp = R_BCNodeStackBase; sp < R_BCNodeStackTop; sp++)`
		1239	`FORWARD_NODE(*sp);`
		1240	`}`
		1241	`#endif`
		1242
11116	ripley	1243	`/* main processing loop */`
11390	luke	1244	`PROCESS_NODES();`
10172	luke	1245
15915	luke	1246	`/* identify weakly reachable nodes */`
		1247	`{`
15928	luke	1248	`Rboolean recheck_weak_refs;`
15915	luke	1249	`do {`
15928	luke	1250	`recheck_weak_refs = FALSE;`
15915	luke	1251	`for (s = R_weak_refs; s != R_NilValue; s = WEAKREF_NEXT(s)) {`
		1252	`if (NODE_IS_MARKED(WEAKREF_KEY(s))) {`
		1253	`if (! NODE_IS_MARKED(WEAKREF_VALUE(s))) {`
		1254	`recheck_weak_refs = TRUE;`
		1255	`FORWARD_NODE(WEAKREF_VALUE(s));`
		1256	`}`
		1257	`if (! NODE_IS_MARKED(WEAKREF_FINALIZER(s))) {`
		1258	`recheck_weak_refs = TRUE;`
		1259	`FORWARD_NODE(WEAKREF_FINALIZER(s));`
		1260	`}`
		1261	`}`
		1262	`}`
		1263	`PROCESS_NODES();`
		1264	`} while (recheck_weak_refs);`
		1265	`}`
		1266
11390	luke	1267	`/* mark nodes ready for finalizing */`
		1268	`CheckFinalizers();`
		1269
15915	luke	1270	`/* process the weak reference chain */`
		1271	`for (s = R_weak_refs; s != R_NilValue; s = WEAKREF_NEXT(s)) {`
		1272	`FORWARD_NODE(s);`
		1273	`FORWARD_NODE(WEAKREF_KEY(s));`
		1274	`FORWARD_NODE(WEAKREF_VALUE(s));`
		1275	`FORWARD_NODE(WEAKREF_FINALIZER(s));`
		1276	`}`
11390	luke	1277	`PROCESS_NODES();`
		1278
11116	ripley	1279	`DEBUG_CHECK_NODE_COUNTS("after processing forwarded list");`
10172	luke	1280
11116	ripley	1281	`/* release large vector allocations */`
		1282	`ReleaseLargeFreeVectors();`
10172	luke	1283
11116	ripley	1284	`DEBUG_CHECK_NODE_COUNTS("after releasing large allocated nodes");`
10172	luke	1285
11116	ripley	1286	`/* reset Free pointers */`
10172	luke	1287	`for (i = 0; i < NUM_NODE_CLASSES; i++)`
11116	ripley	1288	`R_GenHeap[i].Free = NEXT_NODE(R_GenHeap[i].New);`
10172	luke	1289
11116	ripley	1290	`/* update heap statistics */`
		1291	`R_Collected = R_NSize;`
		1292	`R_SmallVallocSize = 0;`
		1293	`for (gen = 0; gen < NUM_OLD_GENERATIONS; gen++) {`
		1294	`for (i = 1; i < NUM_SMALL_NODE_CLASSES; i++)`
		1295	`R_SmallVallocSize += R_GenHeap[i].OldCount[gen] * NodeClassSize[i];`
		1296	`for (i = 0; i < NUM_NODE_CLASSES; i++)`
		1297	`R_Collected -= R_GenHeap[i].OldCount[gen];`
10172	luke	1298	`}`
11116	ripley	1299	`R_NodesInUse = R_NSize - R_Collected;`
		1300
		1301	`if (num_old_gens_to_collect < NUM_OLD_GENERATIONS) {`
		1302	`if (R_Collected < R_MinFreeFrac * R_NSize \|\|`
20094	ripley	1303	`VHEAP_FREE() < size_needed + R_MinFreeFrac * R_VSize) {`
11116	ripley	1304	`num_old_gens_to_collect++;`
		1305	`if (R_Collected <= 0 \|\| VHEAP_FREE() < size_needed)`
		1306	`goto again;`
		1307	`}`
		1308	`else num_old_gens_to_collect = 0;`
		1309	`}`
10172	luke	1310	`else num_old_gens_to_collect = 0;`
		1311
11116	ripley	1312	`gen_gc_counts[gens_collected]++;`
10172	luke	1313
11116	ripley	1314	`if (gens_collected == NUM_OLD_GENERATIONS) {`
		1315	`/**** do some adjustment for intermediate collections? */`
		1316	`AdjustHeapSize(size_needed);`
		1317	`TryToReleasePages();`
		1318	`DEBUG_CHECK_NODE_COUNTS("after heap adjustment");`
		1319	`}`
		1320	`else if (gens_collected > 0) {`
		1321	`TryToReleasePages();`
		1322	`DEBUG_CHECK_NODE_COUNTS("after heap adjustment");`
		1323	`}`
10172	luke	1324	`#ifdef SORT_NODES`
11116	ripley	1325	`if (gens_collected == NUM_OLD_GENERATIONS)`
		1326	`SortNodes();`
10172	luke	1327	`#endif`
		1328
11116	ripley	1329	`if (gc_reporting) {`
		1330	`REprintf("Garbage collection %d = %d", gc_count, gen_gc_counts[0]);`
		1331	`for (i = 0; i < NUM_OLD_GENERATIONS; i++)`
		1332	`REprintf("+%d", gen_gc_counts[i + 1]);`
		1333	`REprintf(" (level %d) ... ", gens_collected);`
		1334	`DEBUG_GC_SUMMARY(gens_collected == NUM_OLD_GENERATIONS);`
		1335	`}`
10172	luke	1336	`}`
		1337
		1338
2512	pd	1339	`SEXP do_gctorture(SEXP call, SEXP op, SEXP args, SEXP rho)`
		1340	`{`
		1341	`int i;`
		1342	`SEXP old = allocVector(LGLSXP, 1);`
		1343
		1344	`checkArity(op, args);`
		1345	`i = asLogical(CAR(args));`
11095	ripley	1346	`LOGICAL(old)[0] = !gc_inhibit_torture;`
2512	pd	1347	`if (i != NA_LOGICAL)`
		1348	`gc_inhibit_torture = !i;`
		1349	`return old;`
		1350	`}`
		1351
2	r	1352	`SEXP do_gcinfo(SEXP call, SEXP op, SEXP args, SEXP rho)`
		1353	`{`
1820	ihaka	1354	`int i;`
2437	maechler	1355	`SEXP old = allocVector(LGLSXP, 1);`
		1356
1820	ihaka	1357	`checkArity(op, args);`
		1358	`i = asLogical(CAR(args));`
2437	maechler	1359	`LOGICAL(old)[0] = gc_reporting;`
1820	ihaka	1360	`if (i != NA_LOGICAL)`
		1361	`gc_reporting = i;`
2437	maechler	1362	`return old;`
2	r	1363	`}`
		1364
		1365	`SEXP do_gc(SEXP call, SEXP op, SEXP args, SEXP rho)`
		1366	`{`
2437	maechler	1367	`SEXP value;`
20094	ripley	1368	`int ogc;`
		1369	`R_size_t onsize = R_NSize;`
11092	ripley	1370
1820	ihaka	1371	`checkArity(op, args);`
2437	maechler	1372	`ogc = gc_reporting;`
		1373	`gc_reporting = asLogical(CAR(args));`
10172	luke	1374	`num_old_gens_to_collect = NUM_OLD_GENERATIONS;`
7750	ripley	1375	`R_gc();`
2437	maechler	1376	`gc_reporting = ogc;`
11092	ripley	1377	`/- now return the [used , gc trigger size] for cells and heap /`
11197	ripley	1378	`PROTECT(value = allocVector(INTSXP, 10));`
11092	ripley	1379	`INTEGER(value)[0] = onsize - R_Collected;`
13180	luke	1380	`INTEGER(value)[1] = R_VSize - VHEAP_FREE();`
20094	ripley	1381	`/* carefully here: we can't report large sizes in R's integer */`
		1382	`INTEGER(value)[4] = (R_NSize < INT_MAX) ? R_NSize : NA_INTEGER;`
		1383	`INTEGER(value)[5] = (R_VSize < INT_MAX) ? R_VSize : NA_INTEGER;`
		1384	`/* next four are in 0.1Mb, rounded up */`
13600	maechler	1385	`INTEGER(value)[2] = 10. * (onsize - R_Collected)/Mega * sizeof(SEXPREC) + 0.999;`
20094	ripley	1386	`INTEGER(value)[3] = 10. * (R_VSize - VHEAP_FREE())/Mega * vsfac + 0.999;`
13600	maechler	1387	`INTEGER(value)[6] = 10. * R_NSize/Mega * sizeof(SEXPREC) + 0.999;`
20094	ripley	1388	`INTEGER(value)[7] = 10. * R_VSize/Mega * vsfac + 0.999;`
		1389	`INTEGER(value)[8] = (R_MaxNSize < R_SIZE_T_MAX) ?`
13600	maechler	1390	`(10. * R_MaxNSize/Mega * sizeof(SEXPREC) + 0.999) : NA_INTEGER;`
20094	ripley	1391	`INTEGER(value)[9] = (R_MaxVSize < R_SIZE_T_MAX) ?`
		1392	`(10. * R_MaxVSize/Mega * vsfac + 0.999) : NA_INTEGER;`
2437	maechler	1393	`UNPROTECT(1);`
		1394	`return value;`
2	r	1395	`}`
		1396
1820	ihaka	1397
20094	ripley	1398	`static void mem_err_heap(R_size_t size)`
1820	ihaka	1399	`{`
11197	ripley	1400	`errorcall(R_NilValue, "vector memory exhausted (limit reached?)");`
1754	pd	1401	`}`
2	r	1402
1820	ihaka	1403
10172	luke	1404	`static void mem_err_cons()`
1820	ihaka	1405	`{`
11197	ripley	1406	`errorcall(R_NilValue, "cons memory exhausted (limit reached?)");`
1754	pd	1407	`}`
		1408
1839	ihaka	1409	`/* InitMemory : Initialise the memory to be used in R. */`
		1410	`/* This includes: stack space, node space and vector space */`
2	r	1411
26646	luke	1412	`#define PP_REDZONE_SIZE 1000L`
		1413	`static R_size_t R_StandardPPStackSize, R_RealPPStackSize;`
		1414
2	r	1415	`void InitMemory()`
		1416	`{`
1820	ihaka	1417	`int i;`
10172	luke	1418	`int gen;`
2	r	1419
2437	maechler	1420	`gc_reporting = R_Verbose;`
26646	luke	1421	`R_StandardPPStackSize = R_PPStackSize;`
		1422	`R_RealPPStackSize = R_PPStackSize + PP_REDZONE_SIZE;`
		1423	`if (!(R_PPStack = (SEXP ) malloc(R_RealPPStackSize sizeof(SEXP))))`
1820	ihaka	1424	`R_Suicide("couldn't allocate memory for pointer stack");`
		1425	`R_PPStackTop = 0;`
2	r	1426
11197	ripley	1427	`vsfac = sizeof(VECREC);`
		1428	`R_VSize = (((R_VSize + 1)/ vsfac));`
2	r	1429
10172	luke	1430	`UNMARK_NODE(&UnmarkedNodeTemplate);`
1160	maechler	1431
10172	luke	1432	`for (i = 0; i < NUM_NODE_CLASSES; i++) {`
		1433	`for (gen = 0; gen < NUM_OLD_GENERATIONS; gen++) {`
		1434	`R_GenHeap[i].Old[gen] = &R_GenHeap[i].OldPeg[gen];`
		1435	`SET_PREV_NODE(R_GenHeap[i].Old[gen], R_GenHeap[i].Old[gen]);`
		1436	`SET_NEXT_NODE(R_GenHeap[i].Old[gen], R_GenHeap[i].Old[gen]);`
2	r	1437
10172	luke	1438	`#ifndef EXPEL_OLD_TO_NEW`
		1439	`R_GenHeap[i].OldToNew[gen] = &R_GenHeap[i].OldToNewPeg[gen];`
		1440	`SET_PREV_NODE(R_GenHeap[i].OldToNew[gen], R_GenHeap[i].OldToNew[gen]);`
		1441	`SET_NEXT_NODE(R_GenHeap[i].OldToNew[gen], R_GenHeap[i].OldToNew[gen]);`
		1442	`#endif`
		1443
		1444	`R_GenHeap[i].OldCount[gen] = 0;`
		1445	`}`
		1446	`R_GenHeap[i].New = &R_GenHeap[i].NewPeg;`
		1447	`SET_PREV_NODE(R_GenHeap[i].New, R_GenHeap[i].New);`
		1448	`SET_NEXT_NODE(R_GenHeap[i].New, R_GenHeap[i].New);`
		1449	`}`
		1450
		1451	`for (i = 0; i < NUM_NODE_CLASSES; i++)`
		1452	`R_GenHeap[i].Free = NEXT_NODE(R_GenHeap[i].New);`
		1453
		1454	`SET_NODE_CLASS(&UnmarkedNodeTemplate, 0);`
		1455	`orig_R_NSize = R_NSize;`
		1456	`orig_R_VSize = R_VSize;`
		1457
		1458	`/* R_NilValue */`
		1459	`/* THIS MUST BE THE FIRST CONS CELL ALLOCATED */`
		1460	`/* OR ARMAGEDDON HAPPENS. */`
		1461	`/* Field assignments for R_NilValue must not go through write barrier`
		1462	`since the write barrier prevents assignments to R_NilValue's fields.`
		1463	`because of checks for nil */`
		1464	`GET_FREE_NODE(R_NilValue);`
		1465	`R_NilValue->sxpinfo = UnmarkedNodeTemplate.sxpinfo;`
		1466	`TYPEOF(R_NilValue) = NILSXP;`
		1467	`CAR(R_NilValue) = R_NilValue;`
		1468	`CDR(R_NilValue) = R_NilValue;`
		1469	`TAG(R_NilValue) = R_NilValue;`
		1470	`ATTRIB(R_NilValue) = R_NilValue;`
11390	luke	1471
26045	luke	1472	`#ifdef BYTECODE`
		1473	`R_BCNodeStackBase = (SEXP ) malloc(R_BCNODESTACKSIZE sizeof(SEXP));`
		1474	`if (R_BCNodeStackBase == NULL)`
		1475	`R_Suicide("couldn't allocate node stack");`
		1476	`# ifdef BC_INT_STACK`
		1477	`R_BCIntStackBase =`
		1478	`(IStackval ) malloc(R_BCINTSTACKSIZE sizeof(IStackval));`
		1479	`if (R_BCIntStackBase == NULL)`
		1480	`R_Suicide("couldn't allocate integer stack");`
		1481	`# endif`
		1482	`R_BCNodeStackTop = R_BCNodeStackBase;`
		1483	`R_BCNodeStackEnd = R_BCNodeStackBase + R_BCNODESTACKSIZE;`
		1484	`# ifdef BC_INT_STACK`
		1485	`R_BCIntStackTop = R_BCIntStackBase;`
		1486	`R_BCIntStackEnd = R_BCIntStackBase + R_BCINTSTACKSIZE;`
		1487	`# endif`
		1488	`#endif`
15915	luke	1489	`R_weak_refs = R_NilValue;`
25523	luke	1490
		1491	`#ifdef NEW_CONDITION_HANDLING`
		1492	`R_HandlerStack = R_RestartStack = R_NilValue;`
		1493	`#endif`
2	r	1494	`}`
		1495
10172	luke	1496	`/* Since memory allocated from the heap is non-moving, R_alloc just`
		1497	`allocates off the heap as CHARSXP's and maintains the stack of`
		1498	`allocations thorugh the ATTRIB pointer. The stack pointer R_VStack`
		1499	`is traced by the collector. */`
		1500	`char *vmaxget(void)`
		1501	`{`
		1502	`return (char *) R_VStack;`
		1503	`}`
2	r	1504
10172	luke	1505	`void vmaxset(char *ovmax)`
		1506	`{`
		1507	`R_VStack = (SEXP) ovmax;`
		1508	`}`
		1509
		1510	`char *R_alloc(long nelem, int eltsize)`
		1511	`{`
20094	ripley	1512	`R_size_t size = nelem * eltsize;`
10172	luke	1513	`if (size > 0) {`
		1514	`SEXP s = allocString(size); /**** avoid extra null byte?? */`
		1515	`ATTRIB(s) = R_VStack;`
		1516	`R_VStack = s;`
		1517	`return CHAR(s);`
		1518	`}`
		1519	`else return NULL;`
		1520	`}`
2	r	1521
		1522	`/* S COMPATIBILITY */`
		1523
		1524	`char *S_alloc(long nelem, int eltsize)`
		1525	`{`
20094	ripley	1526	`R_size_t i, size = nelem * eltsize;`
1820	ihaka	1527	`char *p = R_alloc(nelem, eltsize);`
11116	ripley	1528	`for(i = 0; i < size; i++)`
1820	ihaka	1529	`p[i] = 0;`
		1530	`return p;`
2	r	1531	`}`
		1532
		1533
		1534	`char S_realloc(char p, long new, long old, int size)`
		1535	`{`
1820	ihaka	1536	`int i, nold;`
		1537	`char *q;`
		1538	`/* shrinking is a no-op */`
		1539	`if(new <= old) return p;`
		1540	`q = R_alloc(new, size);`
		1541	`nold = old * size;`
11116	ripley	1542	`for(i = 0; i < nold; i++)`
1820	ihaka	1543	`q[i] = p[i];`
11116	ripley	1544	`for(i = nold; i < new*size; i++)`
7741	ripley	1545	`q[i] = 0;`
1820	ihaka	1546	`return q;`
2	r	1547	`}`
		1548
10172	luke	1549	`/* "allocSExp" allocate a SEXPREC */`
1820	ihaka	1550	`/* call gc if necessary */`
2	r	1551
		1552	`SEXP allocSExp(SEXPTYPE t)`
		1553	`{`
1820	ihaka	1554	`SEXP s;`
10172	luke	1555	`if (FORCE_GC \|\| NO_FREE_NODES()) {`
		1556	`R_gc_internal(0);`
		1557	`if (NO_FREE_NODES())`
1820	ihaka	1558	`mem_err_cons();`
		1559	`}`
10172	luke	1560	`GET_FREE_NODE(s);`
		1561	`s->sxpinfo = UnmarkedNodeTemplate.sxpinfo;`
		1562	`TYPEOF(s) = t;`
1820	ihaka	1563	`CAR(s) = R_NilValue;`
		1564	`CDR(s) = R_NilValue;`
		1565	`TAG(s) = R_NilValue;`
		1566	`ATTRIB(s) = R_NilValue;`
10172	luke	1567	`return s;`
		1568	`}`
		1569
		1570	`static SEXP allocSExpNonCons(SEXPTYPE t)`
		1571	`{`
		1572	`SEXP s;`
		1573	`if (FORCE_GC \|\| NO_FREE_NODES()) {`
		1574	`R_gc_internal(0);`
		1575	`if (NO_FREE_NODES())`
		1576	`mem_err_cons();`
		1577	`}`
		1578	`GET_FREE_NODE(s);`
		1579	`s->sxpinfo = UnmarkedNodeTemplate.sxpinfo;`
1820	ihaka	1580	`TYPEOF(s) = t;`
10172	luke	1581	`TAG(s) = R_NilValue;`
		1582	`ATTRIB(s) = R_NilValue;`
1820	ihaka	1583	`return s;`
2	r	1584	`}`
		1585
10172	luke	1586	`/* cons is defined directly do avoid the need to protect its arguments`
		1587	`unless a GC will actually occur. */`
		1588	`SEXP cons(SEXP car, SEXP cdr)`
		1589	`{`
		1590	`SEXP s;`
		1591	`if (FORCE_GC \|\| NO_FREE_NODES()) {`
		1592	`PROTECT(car);`
		1593	`PROTECT(cdr);`
		1594	`R_gc_internal(0);`
		1595	`UNPROTECT(2);`
		1596	`if (NO_FREE_NODES())`
		1597	`mem_err_cons();`
		1598	`}`
		1599	`GET_FREE_NODE(s);`
		1600	`s->sxpinfo = UnmarkedNodeTemplate.sxpinfo;`
		1601	`TYPEOF(s) = LISTSXP;`
		1602	`CAR(s) = car;`
		1603	`CDR(s) = cdr;`
		1604	`TAG(s) = R_NilValue;`
		1605	`ATTRIB(s) = R_NilValue;`
		1606	`return s;`
		1607	`}`
		1608
10318	luke	1609	`/*----------------------------------------------------------------------`
		1610
		1611	`NewEnvironment`
		1612
		1613	`Create an environment by extending "rho" with a frame obtained by`
		1614	`pairing the variable names given by the tags on "namelist" with`
		1615	`the values given by the elements of "valuelist".`
		1616
16275	luke	1617	`NewEnvironment is defined directly to avoid the need to protect its`
		1618	`arguments unless a GC will actually occur. This definition allows`
		1619	`the namelist argument to be shorter than the valuelist; in this`
		1620	`case the remaining values must be named already. (This is useful`
		1621	`in cases where the entire valuelist is already named--namelist can`
		1622	`then be R_NilValue`
		1623
		1624	`The valuelist is destructively modified and used as the`
		1625	`environment's frame.`
10318	luke	1626	`*/`
10172	luke	1627	`SEXP NewEnvironment(SEXP namelist, SEXP valuelist, SEXP rho)`
		1628	`{`
		1629	`SEXP v, n, newrho;`
		1630
		1631	`if (FORCE_GC \|\| NO_FREE_NODES()) {`
		1632	`PROTECT(namelist);`
		1633	`PROTECT(valuelist);`
		1634	`PROTECT(rho);`
		1635	`R_gc_internal(0);`
		1636	`UNPROTECT(3);`
		1637	`if (NO_FREE_NODES())`
		1638	`mem_err_cons();`
		1639	`}`
		1640	`GET_FREE_NODE(newrho);`
		1641	`newrho->sxpinfo = UnmarkedNodeTemplate.sxpinfo;`
		1642	`TYPEOF(newrho) = ENVSXP;`
		1643	`FRAME(newrho) = valuelist;`
		1644	`ENCLOS(newrho) = rho;`
		1645	`HASHTAB(newrho) = R_NilValue;`
		1646	`ATTRIB(newrho) = R_NilValue;`
		1647
		1648	`v = valuelist;`
		1649	`n = namelist;`
10318	luke	1650	`while (v != R_NilValue && n != R_NilValue) {`
10172	luke	1651	`SET_TAG(v, TAG(n));`
		1652	`v = CDR(v);`
		1653	`n = CDR(n);`
		1654	`}`
		1655	`return (newrho);`
		1656	`}`
		1657
		1658	`/* mkPROMISE is defined directly do avoid the need to protect its arguments`
		1659	`unless a GC will actually occur. */`
		1660	`SEXP mkPROMISE(SEXP expr, SEXP rho)`
		1661	`{`
		1662	`SEXP s;`
		1663	`if (FORCE_GC \|\| NO_FREE_NODES()) {`
		1664	`PROTECT(expr);`
		1665	`PROTECT(rho);`
		1666	`R_gc_internal(0);`
		1667	`UNPROTECT(2);`
		1668	`if (NO_FREE_NODES())`
		1669	`mem_err_cons();`
		1670	`}`
		1671	`GET_FREE_NODE(s);`
		1672	`s->sxpinfo = UnmarkedNodeTemplate.sxpinfo;`
		1673	`TYPEOF(s) = PROMSXP;`
26020	luke	1674	`PRCODE(s) = expr;`
10172	luke	1675	`PRENV(s) = rho;`
		1676	`PRVALUE(s) = R_UnboundValue;`
		1677	`PRSEEN(s) = 0;`
		1678	`ATTRIB(s) = R_NilValue;`
		1679	`return s;`
		1680	`}`
		1681
1820	ihaka	1682	`/* "allocString" allocate a string on the (vector) heap. */`
		1683	`/* All vector objects must be a multiple of sizeof(ALIGN) */`
		1684	`/* bytes so that alignment is preserved for all objects */`
2	r	1685
		1686	`SEXP allocString(int length)`
		1687	`{`
10172	luke	1688	`return allocVector(CHARSXP, length);`
2	r	1689	`}`
		1690
		1691
1820	ihaka	1692	`/* Allocate a vector object on the heap */`
2	r	1693
28362	murdoch	1694	`SEXP allocVector(SEXPTYPE type, R_len_t length)`
2	r	1695	`{`
10910	luke	1696	`SEXP s; /* For the generational collector it would be safer to`
		1697	`work in terms of a VECSEXP here, but that would`
		1698	`require several casts below... */`
28362	murdoch	1699	`R_len_t i;`
20094	ripley	1700	`R_size_t size = 0, alloc_size, old_R_VSize;`
10172	luke	1701	`int node_class;`
		1702
1820	ihaka	1703	`if (length < 0 )`
		1704	`errorcall(R_GlobalContext->call,`
5731	ripley	1705	`"negative length vectors are not allowed");`
1820	ihaka	1706	`/* number of vector cells to allocate */`
		1707	`switch (type) {`
		1708	`case NILSXP:`
		1709	`return R_NilValue;`
		1710	`case CHARSXP:`
10172	luke	1711	`size = BYTE2VEC(length + 1);`
1820	ihaka	1712	`break;`
		1713	`case LGLSXP:`
		1714	`case INTSXP:`
		1715	`if (length <= 0)`
		1716	`size = 0;`
16410	luke	1717	`else {`
20094	ripley	1718	`if (length > R_SIZE_T_MAX / sizeof(int))`
16410	luke	1719	`errorcall(R_GlobalContext->call,`
		1720	`"cannot allocate vector of length %d", length);`
10172	luke	1721	`size = INT2VEC(length);`
16410	luke	1722	`}`
1820	ihaka	1723	`break;`
		1724	`case REALSXP:`
		1725	`if (length <= 0)`
		1726	`size = 0;`
16410	luke	1727	`else {`
20094	ripley	1728	`if (length > R_SIZE_T_MAX / sizeof(double))`
16410	luke	1729	`errorcall(R_GlobalContext->call,`
		1730	`"cannot allocate vector of length %d", length);`
10172	luke	1731	`size = FLOAT2VEC(length);`
16410	luke	1732	`}`
1820	ihaka	1733	`break;`
		1734	`case CPLXSXP:`
		1735	`if (length <= 0)`
		1736	`size = 0;`
16410	luke	1737	`else {`
20094	ripley	1738	`if (length > R_SIZE_T_MAX / sizeof(Rcomplex))`
16410	luke	1739	`errorcall(R_GlobalContext->call,`
		1740	`"cannot allocate vector of length %d", length);`
10172	luke	1741	`size = COMPLEX2VEC(length);`
16410	luke	1742	`}`
1820	ihaka	1743	`break;`
		1744	`case STRSXP:`
		1745	`case EXPRSXP:`
		1746	`case VECSXP:`
		1747	`if (length <= 0)`
		1748	`size = 0;`
16410	luke	1749	`else {`
20094	ripley	1750	`if (length > R_SIZE_T_MAX / sizeof(SEXP))`
16410	luke	1751	`errorcall(R_GlobalContext->call,`
		1752	`"cannot allocate vector of length %d", length);`
10172	luke	1753	`size = PTR2VEC(length);`
16410	luke	1754	`}`
1820	ihaka	1755	`break;`
		1756	`case LANGSXP:`
		1757	`if(length == 0) return R_NilValue;`
		1758	`s = allocList(length);`
		1759	`TYPEOF(s) = LANGSXP;`
		1760	`return s;`
		1761	`case LISTSXP:`
		1762	`return allocList(length);`
		1763	`default:`
5731	ripley	1764	`error("invalid type/length (%d/%d) in vector allocation", type, length);`
1820	ihaka	1765	`}`
10172	luke	1766
		1767	`if (size <= NodeClassSize[1]) {`
		1768	`node_class = 1;`
		1769	`alloc_size = NodeClassSize[1];`
		1770	`}`
		1771	`else {`
		1772	`node_class = LARGE_NODE_CLASS;`
		1773	`alloc_size = size;`
		1774	`for (i = 2; i < NUM_SMALL_NODE_CLASSES; i++) {`
		1775	`if (size <= NodeClassSize[i]) {`
		1776	`node_class = i;`
		1777	`alloc_size = NodeClassSize[i];`
		1778	`break;`
		1779	`}`
		1780	`}`
		1781	`}`
		1782
		1783	`/* save current R_VSize to roll back adjustment if malloc fails */`
		1784	`old_R_VSize = R_VSize;`
		1785
1820	ihaka	1786	`/* we need to do the gc here so allocSExp doesn't! */`
20094	ripley	1787	`if (FORCE_GC \|\| NO_FREE_NODES() \|\| VHEAP_FREE() < alloc_size) {`
10172	luke	1788	`R_gc_internal(alloc_size);`
		1789	`if (NO_FREE_NODES())`
1820	ihaka	1790	`mem_err_cons();`
10172	luke	1791	`if (VHEAP_FREE() < alloc_size)`
2437	maechler	1792	`mem_err_heap(size);`
1820	ihaka	1793	`}`
2100	pd	1794
1820	ihaka	1795	`if (size > 0) {`
11116	ripley	1796	`if (node_class < NUM_SMALL_NODE_CLASSES) {`
		1797	`CLASS_GET_FREE_NODE(node_class, s);`
		1798	`s->sxpinfo = UnmarkedNodeTemplate.sxpinfo;`
		1799	`SET_NODE_CLASS(s, node_class);`
		1800	`R_SmallVallocSize += alloc_size;`
10172	luke	1801	`}`
11116	ripley	1802	`else {`
		1803	`s = NULL; /* initialize to suppress warning */`
		1804	`if (size >= (LONG_MAX / sizeof(VECREC)) - sizeof(SEXPREC_ALIGN) \|\|`
		1805	`(s = malloc(sizeof(SEXPREC_ALIGN) + size * sizeof(VECREC)))`
		1806	`== NULL) {`
		1807	`/* reset the vector heap limit */`
		1808	`R_VSize = old_R_VSize;`
20094	ripley	1809	`errorcall(R_NilValue, "cannot allocate vector of size %lu Kb",`
11116	ripley	1810	`(size * sizeof(VECREC))/1024);`
		1811	`}`
		1812	`s->sxpinfo = UnmarkedNodeTemplate.sxpinfo;`
		1813	`SET_NODE_CLASS(s, LARGE_NODE_CLASS);`
20094	ripley	1814	`R_LargeVallocSize += size;`
11116	ripley	1815	`R_GenHeap[LARGE_NODE_CLASS].AllocCount++;`
20713	luke	1816	`R_NodesInUse++;`
11116	ripley	1817	`SNAP_NODE(s, R_GenHeap[LARGE_NODE_CLASS].New);`
		1818	`}`
		1819	`ATTRIB(s) = R_NilValue;`
		1820	`TYPEOF(s) = type;`
1820	ihaka	1821	`}`
10172	luke	1822	`else {`
		1823	`GC_PROT(s = allocSExpNonCons(type));`
		1824	`}`
		1825	`LENGTH(s) = length;`
		1826	`NAMED(s) = 0;`
		1827
1820	ihaka	1828	`/* The following prevents disaster in the case */`
		1829	`/* that an uninitialised string vector is marked */`
10910	luke	1830	`/* Direct assignment is OK since the node was just allocated and */`
		1831	`/* so is at least as new as R_NilValue and R_BlankString */`
4849	ihaka	1832	`if (type == EXPRSXP \|\| type == VECSXP) {`
10910	luke	1833	`SEXP *data = STRING_PTR(s);`
1820	ihaka	1834	`for (i = 0; i < length; i++)`
10910	luke	1835	`data[i] = R_NilValue;`
1820	ihaka	1836	`}`
4849	ihaka	1837	`else if(type == STRSXP) {`
10910	luke	1838	`SEXP *data = STRING_PTR(s);`
4849	ihaka	1839	`for (i = 0; i < length; i++)`
10910	luke	1840	`data[i] = R_BlankString;`
4849	ihaka	1841	`}`
16455	luke	1842	`else if (type == CHARSXP)`
		1843	`CHAR(s)[length] = 0;`
1820	ihaka	1844	`return s;`
2	r	1845	`}`
		1846
		1847	`SEXP allocList(int n)`
		1848	`{`
1820	ihaka	1849	`int i;`
		1850	`SEXP result;`
		1851	`result = R_NilValue;`
		1852	`for (i = 0; i < n; i++) {`
		1853	`result = CONS(R_NilValue, result);`
		1854	`}`
		1855	`return result;`
2	r	1856	`}`
		1857
10172	luke	1858	`/* "gc" a mark-sweep or in-place generational garbage collector */`
2	r	1859
11197	ripley	1860	`void R_gc(void)`
		1861	`{`
		1862	`R_gc_internal(0);`
		1863	`}`
10172	luke	1864
19066	hornik	1865	`#ifdef _R_HAVE_TIMING_`
10172	luke	1866	`double R_getClockIncrement(void);`
		1867	`void R_getProcTime(double *data);`
		1868
		1869	`static double gctimes[5], gcstarttimes[5];`
25199	luke	1870	`static Rboolean gctime_enabled = FALSE;`
10172	luke	1871
		1872	`SEXP do_gctime(SEXP call, SEXP op, SEXP args, SEXP env)`
2	r	1873	`{`
19066	hornik	1874	`SEXP ans;`
25199	luke	1875	`if (args == R_NilValue)`
		1876	`gctime_enabled = TRUE;`
		1877	`else`
		1878	`gctime_enabled = asLogical(CAR(args));`
19066	hornik	1879	`ans = allocVector(REALSXP, 5);`
		1880	`REAL(ans)[0] = gctimes[0];`
		1881	`REAL(ans)[1] = gctimes[1];`
		1882	`REAL(ans)[2] = gctimes[2];`
		1883	`REAL(ans)[3] = gctimes[3];`
		1884	`REAL(ans)[4] = gctimes[4];`
		1885	`return ans;`
10172	luke	1886	`}`
19066	hornik	1887	`#else /* not _R_HAVE_TIMING_ */`
		1888	`SEXP do_gctime(SEXP call, SEXP op, SEXP args, SEXP env)`
		1889	`{`
		1890	`error("gc.time is not implemented on this system");`
		1891	`return R_NilValue; /* -Wall */`
		1892	`}`
		1893	`#endif /* not _R_HAVE_TIMING_ */`
10172	luke	1894
		1895	`static void gc_start_timing(void)`
		1896	`{`
19066	hornik	1897	`#ifdef _R_HAVE_TIMING_`
25199	luke	1898	`if (gctime_enabled)`
		1899	`R_getProcTime(gcstarttimes);`
19066	hornik	1900	`#endif /* _R_HAVE_TIMING_ */`
10172	luke	1901	`}`
10407	maechler	1902
10172	luke	1903	`static void gc_end_timing(void)`
		1904	`{`
19066	hornik	1905	`#ifdef _R_HAVE_TIMING_`
25199	luke	1906	`if (gctime_enabled) {`
		1907	`double times[5], delta;`
		1908	`R_getProcTime(times);`
		1909	`delta = R_getClockIncrement();`
10172	luke	1910
25199	luke	1911	`/* add delta to compensate for timer resolution */`
		1912	`gctimes[0] += times[0] - gcstarttimes[0] + delta;`
		1913	`gctimes[1] += times[1] - gcstarttimes[1] + delta;`
		1914	`gctimes[2] += times[2] - gcstarttimes[2] + delta;`
		1915	`gctimes[3] += times[3] - gcstarttimes[3];`
		1916	`gctimes[4] += times[4] - gcstarttimes[4];`
		1917	`}`
19066	hornik	1918	`#endif /* _R_HAVE_TIMING_ */`
10172	luke	1919	`}`
		1920
20094	ripley	1921	`static void R_gc_internal(R_size_t size_needed)`
10172	luke	1922	`{`
20094	ripley	1923	`R_size_t vcells;`
6366	ripley	1924	`double vfrac;`
11390	luke	1925	`Rboolean first = TRUE;`
2437	maechler	1926
11390	luke	1927	`again:`
		1928
1858	ihaka	1929	`gc_count++;`
8686	luke	1930
		1931	`BEGIN_SUSPEND_INTERRUPTS {`
10172	luke	1932	`gc_start_timing();`
		1933	`RunGenCollect(size_needed);`
		1934	`gc_end_timing();`
8686	luke	1935	`} END_SUSPEND_INTERRUPTS;`
		1936
1820	ihaka	1937	`if (gc_reporting) {`
11116	ripley	1938	`REprintf("\n%d cons cells free (%d%%)\n",`
1820	ihaka	1939	`R_Collected, (100 * R_Collected / R_NSize));`
10172	luke	1940	`vcells = VHEAP_FREE();`
6366	ripley	1941	`vfrac = (100.0 * vcells) / R_VSize;`
11197	ripley	1942	`/* arrange for percentage to be rounded down, or we get`
11116	ripley	1943	`100% free' ! */
		1944	`REprintf("%.1f Mbytes of heap free (%d%%)\n",`
		1945	`vcells * sizeof(VECREC) / Mega, (int)vfrac);`
1820	ihaka	1946	`}`
11390	luke	1947
		1948	`if (first) {`
		1949	`first = FALSE;`
		1950	`/* Run any eligible finalizers. The return result of`
		1951	`RunFinalizers is TRUE if any finalizers are actually run.`
		1952	`There is a small chance that running finalizers here may`
		1953	`chew up enough memory to make another immediate collection`
		1954	`necessary. If so, we jump back to the beginning and run`
		1955	`the collection, but on this second pass we do not run`
		1956	`finalizers. */`
		1957	`if (RunFinalizers() &&`
		1958	`(NO_FREE_NODES() \|\| size_needed > VHEAP_FREE()))`
		1959	`goto again;`
		1960	`}`
2	r	1961	`}`
		1962
11197	ripley	1963	`SEXP do_memlimits(SEXP call, SEXP op, SEXP args, SEXP env)`
		1964	`{`
		1965	`SEXP ans;`
20094	ripley	1966	`int nsize, vsize;`
		1967	`R_size_t tmp;`
11197	ripley	1968
		1969	`checkArity(op, args);`
		1970	`nsize = asInteger(CAR(args));`
		1971	`vsize = asInteger(CADR(args));`
20094	ripley	1972	`if(nsize != NA_INTEGER) R_SetMaxNSize((R_size_t) nsize);`
		1973	`if(vsize != NA_INTEGER) R_SetMaxVSize((R_size_t) vsize);`
11197	ripley	1974	`PROTECT(ans = allocVector(INTSXP, 2));`
		1975	`tmp = R_GetMaxNSize();`
20094	ripley	1976	`INTEGER(ans)[0] = (tmp < INT_MAX) ? tmp : NA_INTEGER;`
11197	ripley	1977	`tmp = R_GetMaxVSize();`
20094	ripley	1978	`INTEGER(ans)[1] = (tmp < INT_MAX) ? tmp : NA_INTEGER;`
11197	ripley	1979	`UNPROTECT(1);`
		1980	`return ans;`
		1981	`}`
2	r	1982
3558	r	1983	`SEXP do_memoryprofile(SEXP call, SEXP op, SEXP args, SEXP env)`
		1984	`{`
		1985	`SEXP ans, nms;`
		1986	`int i;`
8686	luke	1987
15928	luke	1988	`PROTECT(ans = allocVector(INTSXP, 24));`
		1989	`PROTECT(nms = allocVector(STRSXP, 24));`
		1990	`for (i = 0; i < 24; i++) {`
6994	pd	1991	`INTEGER(ans)[i] = 0;`
10172	luke	1992	`SET_STRING_ELT(nms, i, R_BlankString);`
3558	r	1993	`}`
10172	luke	1994	`SET_STRING_ELT(nms, NILSXP, mkChar("NILSXP"));`
		1995	`SET_STRING_ELT(nms, SYMSXP, mkChar("SYMSXP"));`
		1996	`SET_STRING_ELT(nms, LISTSXP, mkChar("LISTSXP"));`
		1997	`SET_STRING_ELT(nms, CLOSXP, mkChar("CLOSXP"));`
		1998	`SET_STRING_ELT(nms, ENVSXP, mkChar("ENVSXP"));`
		1999	`SET_STRING_ELT(nms, PROMSXP, mkChar("PROMSXP"));`
		2000	`SET_STRING_ELT(nms, LANGSXP, mkChar("LANGSXP"));`
		2001	`SET_STRING_ELT(nms, SPECIALSXP, mkChar("SPECIALSXP"));`
		2002	`SET_STRING_ELT(nms, BUILTINSXP, mkChar("BUILTINSXP"));`
		2003	`SET_STRING_ELT(nms, CHARSXP, mkChar("CHARSXP"));`
		2004	`SET_STRING_ELT(nms, LGLSXP, mkChar("LGLSXP"));`
		2005	`SET_STRING_ELT(nms, INTSXP, mkChar("INTSXP"));`
		2006	`SET_STRING_ELT(nms, REALSXP, mkChar("REALSXP"));`
		2007	`SET_STRING_ELT(nms, CPLXSXP, mkChar("CPLXSXP"));`
		2008	`SET_STRING_ELT(nms, STRSXP, mkChar("STRSXP"));`
		2009	`SET_STRING_ELT(nms, DOTSXP, mkChar("DOTSXP"));`
		2010	`SET_STRING_ELT(nms, ANYSXP, mkChar("ANYSXP"));`
		2011	`SET_STRING_ELT(nms, VECSXP, mkChar("VECSXP"));`
		2012	`SET_STRING_ELT(nms, EXPRSXP, mkChar("EXPRSXP"));`
26045	luke	2013	`#ifdef BYTECODE`
		2014	`SET_STRING_ELT(nms, BCODESXP, mkChar("BCODESXP"));`
		2015	`#endif`
11390	luke	2016	`SET_STRING_ELT(nms, EXTPTRSXP, mkChar("EXTPTRSXP"));`
15928	luke	2017	`SET_STRING_ELT(nms, WEAKREFSXP, mkChar("WEAKREFSXP"));`
8686	luke	2018	`setAttrib(ans, R_NamesSymbol, nms);`
		2019
		2020	`BEGIN_SUSPEND_INTERRUPTS {`
10172	luke	2021	`int gen;`
		2022
		2023	`/* run a full GC to make sure that all stuff in use in in Old space */`
		2024	`num_old_gens_to_collect = NUM_OLD_GENERATIONS;`
		2025	`R_gc();`
		2026	`for (gen = 0; gen < NUM_OLD_GENERATIONS; gen++) {`
		2027	`for (i = 0; i < NUM_NODE_CLASSES; i++) {`
		2028	`SEXP s;`
		2029	`for (s = NEXT_NODE(R_GenHeap[i].Old[gen]);`
		2030	`s != R_GenHeap[i].Old[gen];`
		2031	`s = NEXT_NODE(s))`
		2032	`INTEGER(ans)[TYPEOF(s)]++;`
		2033	`}`
		2034	`}`
8686	luke	2035	`} END_SUSPEND_INTERRUPTS;`
3558	r	2036	`UNPROTECT(2);`
		2037	`return ans;`
		2038	`}`
		2039
1820	ihaka	2040	`/* "protect" push a single argument onto R_PPStack */`
		2041
26646	luke	2042	`/* In handling a stack overflow we have to be careful not to use`
		2043	`PROTECT. error("protect(): stack overflow") would call deparse1,`
		2044	`which uses PROTECT and segfaults.*/`
10407	maechler	2045
26646	luke	2046	`/* However, the traceback creation in the normal error handler also`
		2047	`does a PROTECT, as does the jumping code, at least if there are`
		2048	`cleanup expressions to handle on the way out. So for the moment`
		2049	`we'll allocate a slightly larger PP stack and only enable the added`
		2050	`red zone during handling of a stack overflow error. LT */`
		2051
		2052	`static void reset_pp_stack(void *data)`
		2053	`{`
		2054	`R_size_t *poldpps = data;`
		2055	`R_PPStackSize = *poldpps;`
		2056	`}`
2579	pd	2057	`SEXP protect(SEXP s)`
2	r	2058	`{`
26646	luke	2059	`if (R_PPStackTop >= R_PPStackSize) {`
		2060	`RCNTXT cntxt;`
		2061	`R_size_t oldpps = R_PPStackSize;`
		2062
		2063	`begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_NilValue, R_NilValue,`
		2064	`R_NilValue, R_NilValue);`
		2065	`cntxt.cend = &reset_pp_stack;`
		2066	`cntxt.cenddata = &oldpps;`
		2067
		2068	`if (R_PPStackSize < R_RealPPStackSize)`
		2069	`R_PPStackSize = R_RealPPStackSize;`
11116	ripley	2070	`errorcall(R_NilValue, "protect(): stack overflow");`
26646	luke	2071
		2072	`endcontext(&cntxt); /* not reached */`
		2073	`}`
8657	pd	2074	`R_PPStack[R_PPStackTop++] = s;`
2579	pd	2075	`return s;`
2	r	2076	`}`
		2077
		2078
1820	ihaka	2079	`/* "unprotect" pop argument list from top of R_PPStack */`
		2080
2	r	2081	`void unprotect(int l)`
		2082	`{`
8657	pd	2083	`if (R_PPStackTop >= l)`
		2084	`R_PPStackTop -= l;`
1820	ihaka	2085	`else`
5731	ripley	2086	`error("unprotect(): stack imbalance");`
2	r	2087	`}`
		2088
2408	pd	2089	`/* "unprotect_ptr" remove pointer from somewhere in R_PPStack */`
2	r	2090
2408	pd	2091	`void unprotect_ptr(SEXP s)`
		2092	`{`
		2093	`int i = R_PPStackTop;`
2437	maechler	2094
2408	pd	2095	`/* go look for s in R_PPStack */`
		2096	`/* (should be among the top few items) */`
		2097	`do {`
		2098	`if (i == 0)`
5731	ripley	2099	`error("unprotect_ptr: pointer not found");`
2408	pd	2100	`} while ( R_PPStack[--i] != s );`
		2101
		2102	`/* OK, got it, and i is indexing its location */`
		2103	`/* Now drop stack above it */`
		2104
		2105	`do {`
		2106	`R_PPStack[i] = R_PPStack[i + 1];`
		2107	`} while ( i++ < R_PPStackTop );`
		2108
		2109	`R_PPStackTop--;`
		2110	`}`
		2111
10776	luke	2112	`void R_ProtectWithIndex(SEXP s, PROTECT_INDEX *pi)`
		2113	`{`
11116	ripley	2114	`protect(s);`
		2115	`*pi = R_PPStackTop - 1;`
10776	luke	2116	`}`
2408	pd	2117
10776	luke	2118	`void R_Reprotect(SEXP s, PROTECT_INDEX i)`
		2119	`{`
11116	ripley	2120	`R_PPStack[i] = s;`
10776	luke	2121	`}`
		2122
		2123
1820	ihaka	2124	`/* "initStack" initialize environment stack */`
2	r	2125	`void initStack(void)`
		2126	`{`
1820	ihaka	2127	`R_PPStackTop = 0;`
2	r	2128	`}`
563	ihaka	2129
		2130
3795	ripley	2131	`/* S-like wrappers for calloc, realloc and free that check for error`
		2132	`conditions */`
		2133
		2134	`void *R_chk_calloc(size_t nelem, size_t elsize)`
		2135	`{`
3875	hornik	2136	`void *p;`
15252	hornik	2137	`#ifndef HAVE_WORKING_CALLOC`
5377	hornik	2138	`if(nelem == 0)`
		2139	`return(NULL);`
		2140	`#endif`
3875	hornik	2141	`p = calloc(nelem, elsize);`
10407	maechler	2142	`if(!p) error("Calloc could not allocate (%d of %d) memory", nelem, elsize);`
3875	hornik	2143	`return(p);`
3795	ripley	2144	`}`
		2145	`void R_chk_realloc(void ptr, size_t size)`
		2146	`{`
3875	hornik	2147	`void *p;`
19853	ripley	2148	`/* Protect against broken realloc */`
		2149	`if(ptr) p = realloc(ptr, size); else p = malloc(size);`
10407	maechler	2150	`if(!p) error("Realloc could not re-allocate (size %d) memory", size);`
3875	hornik	2151	`return(p);`
3795	ripley	2152	`}`
3875	hornik	2153	`void R_chk_free(void *ptr)`
3795	ripley	2154	`{`
6374	ripley	2155	`/* S-PLUS warns here, but there seems no reason to do so */`
		2156	`/* if(!ptr) warning("attempt to free NULL pointer by Free"); */`
		2157	`if(ptr) free(ptr); /* ANSI C says free has no effect on NULL, but`
		2158	`better to be safe here */`
3795	ripley	2159	`}`
4881	ihaka	2160
		2161	`/* This code keeps a list of objects which are not assigned to variables`
		2162	`but which are required to persist across garbage collections. The`
4887	ihaka	2163	`objects are registered with R_PreserveObject and deregistered with`
25927	ripley	2164	`R_ReleaseObject. */`
4881	ihaka	2165
		2166	`void R_PreserveObject(SEXP object)`
		2167	`{`
		2168	`R_PreciousList = CONS(object, R_PreciousList);`
		2169	`}`
		2170
		2171	`static SEXP RecursiveRelease(SEXP object, SEXP list)`
		2172	`{`
		2173	`if (!isNull(list)) {`
		2174	`if (object == CAR(list))`
		2175	`return CDR(list);`
		2176	`else`
		2177	`CDR(list) = RecursiveRelease(object, CDR(list));`
		2178	`}`
		2179	`return list;`
		2180	`}`
		2181
		2182	`void R_ReleaseObject(SEXP object)`
		2183	`{`
		2184	`R_PreciousList = RecursiveRelease(object, R_PreciousList);`
		2185	`}`
10172	luke	2186
10407	maechler	2187
11390	luke	2188	`/* External Pointer Objects */`
		2189	`SEXP R_MakeExternalPtr(void *p, SEXP tag, SEXP prot)`
		2190	`{`
		2191	`SEXP s = allocSExp(EXTPTRSXP);`
		2192	`EXTPTR_PTR(s) = p;`
		2193	`EXTPTR_PROT(s) = prot;`
		2194	`EXTPTR_TAG(s) = tag;`
		2195	`return s;`
		2196	`}`
		2197
		2198	`void *R_ExternalPtrAddr(SEXP s)`
		2199	`{`
		2200	`return EXTPTR_PTR(s);`
		2201	`}`
		2202
		2203	`SEXP R_ExternalPtrTag(SEXP s)`
		2204	`{`
		2205	`return EXTPTR_TAG(s);`
		2206	`}`
		2207
		2208	`SEXP R_ExternalPtrProtected(SEXP s)`
		2209	`{`
		2210	`return EXTPTR_PROT(s);`
		2211	`}`
		2212
		2213	`void R_ClearExternalPtr(SEXP s)`
		2214	`{`
		2215	`EXTPTR_PTR(s) = NULL;`
		2216	`}`
		2217
		2218	`void R_SetExternalPtrAddr(SEXP s, void *p)`
		2219	`{`
		2220	`EXTPTR_PTR(s) = p;`
		2221	`}`
		2222
		2223	`void R_SetExternalPtrTag(SEXP s, SEXP tag)`
		2224	`{`
		2225	`CHECK_OLD_TO_NEW(s, tag);`
		2226	`EXTPTR_TAG(s) = tag;`
		2227	`}`
		2228
		2229	`void R_SetExternalPtrProtected(SEXP s, SEXP p)`
		2230	`{`
		2231	`CHECK_OLD_TO_NEW(s, p);`
		2232	`EXTPTR_PROT(s) = p;`
		2233	`}`
		2234
		2235
10172	luke	2236	`/* The following functions are replacements for the accessor macros.`
		2237	`They are used by code that does not have direct access to the`
		2238	`internal representation of objects. The assignment functions`
		2239	`implement the write barrier. */`
		2240
		2241	`/* General Cons Cell Attributes */`
		2242	`SEXP (ATTRIB)(SEXP x) { return ATTRIB(x); }`
		2243	`int (OBJECT)(SEXP x) { return OBJECT(x); }`
		2244	`int (MARK)(SEXP x) { return MARK(x); }`
		2245	`int (TYPEOF)(SEXP x) { return TYPEOF(x); }`
		2246	`int (NAMED)(SEXP x) { return NAMED(x); }`
		2247
		2248	`void (SET_ATTRIB)(SEXP x, SEXP v) { CHECK_OLD_TO_NEW(x, v); ATTRIB(x) = v; }`
		2249	`void (SET_OBJECT)(SEXP x, int v) { SET_OBJECT(x, v); }`
		2250	`void (SET_TYPEOF)(SEXP x, int v) { SET_TYPEOF(x, v); }`
		2251	`void (SET_NAMED)(SEXP x, int v) { SET_NAMED(x, v); }`
		2252
		2253	`/* Vector Accessors */`
		2254	`int (LENGTH)(SEXP x) { return LENGTH(x); }`
		2255	`int (TRUELENGTH)(SEXP x) { return TRUELENGTH(x); }`
		2256	`char *(R_CHAR)(SEXP x) { return CHAR(x); }`
		2257	`SEXP (STRING_ELT)(SEXP x, int i) { return STRING_ELT(x, i); }`
		2258	`SEXP (VECTOR_ELT)(SEXP x, int i) { return VECTOR_ELT(x, i); }`
		2259	`int (LEVELS)(SEXP x) { return LEVELS(x); }`
		2260
		2261	`int *(LOGICAL)(SEXP x) { return LOGICAL(x); }`
		2262	`int *(INTEGER)(SEXP x) { return INTEGER(x); }`
		2263	`double *(REAL)(SEXP x) { return REAL(x); }`
		2264	`Rcomplex *(COMPLEX)(SEXP x) { return COMPLEX(x); }`
		2265	`SEXP *(STRING_PTR)(SEXP x) { return STRING_PTR(x); }`
		2266	`SEXP *(VECTOR_PTR)(SEXP x)`
		2267	`{`
		2268	`error("not safe to return vector pointer");`
		2269	`return NULL;`
		2270	`}`
		2271
		2272	`void (SETLENGTH)(SEXP x, int v) { SETLENGTH(x, v); }`
		2273	`void (SET_TRUELENGTH)(SEXP x, int v) { SET_TRUELENGTH(x, v); }`
		2274	`void (SET_STRING_ELT)(SEXP x, int i, SEXP v) { CHECK_OLD_TO_NEW(x, v); STRING_ELT(x, i) = v; }`
		2275	`SEXP (SET_VECTOR_ELT)(SEXP x, int i, SEXP v) { CHECK_OLD_TO_NEW(x, v); return VECTOR_ELT(x, i) =v; }`
		2276	`int (SETLEVELS)(SEXP x, int v) { return SETLEVELS(x, v); }`
		2277
		2278	`/* List Accessors */`
		2279	`SEXP (TAG)(SEXP e) { return TAG(e); }`
		2280	`SEXP (CAR)(SEXP e) { return CAR(e); }`
		2281	`SEXP (CDR)(SEXP e) {return CDR(e); }`
		2282	`SEXP (CAAR)(SEXP e) { return CAAR(e); }`
		2283	`SEXP (CDAR)(SEXP e) { return CDAR(e); }`
		2284	`SEXP (CADR)(SEXP e) { return CADR(e); }`
		2285	`SEXP (CDDR)(SEXP e) { return CDDR(e); }`
		2286	`SEXP (CADDR)(SEXP e) { return CADDR(e); }`
		2287	`SEXP (CADDDR)(SEXP e) { return CADDDR(e); }`
		2288	`SEXP (CAD4R)(SEXP e) { return CAD4R(e); }`
		2289	`int (MISSING)(SEXP x) { return MISSING(x); }`
		2290
		2291	`void (SET_TAG)(SEXP x, SEXP v) { CHECK_OLD_TO_NEW(x, v); TAG(x) = v; }`
		2292
		2293	`SEXP (SETCAR)(SEXP x, SEXP y)`
		2294	`{`
		2295	`if (x == NULL \|\| x == R_NilValue)`
		2296	`error("bad value");`
		2297	`CHECK_OLD_TO_NEW(x, y);`
		2298	`CAR(x) = y;`
		2299	`return y;`
		2300	`}`
		2301
		2302	`SEXP (SETCDR)(SEXP x, SEXP y)`
		2303	`{`
		2304	`if (x == NULL \|\| x == R_NilValue)`
		2305	`error("bad value");`
		2306	`CHECK_OLD_TO_NEW(x, y);`
		2307	`CDR(x) = y;`
		2308	`return y;`
		2309	`}`
		2310
		2311	`SEXP (SETCADR)(SEXP x, SEXP y)`
		2312	`{`
		2313	`SEXP cell;`
		2314	`if (x == NULL \|\| x == R_NilValue \|\|`
		2315	`CDR(x) == NULL \|\| CDR(x) == R_NilValue)`
		2316	`error("bad value");`
		2317	`cell = CDR(x);`
		2318	`CHECK_OLD_TO_NEW(cell, y);`
		2319	`CAR(cell) = y;`
		2320	`return y;`
		2321	`}`
		2322
		2323	`SEXP (SETCADDR)(SEXP x, SEXP y)`
		2324	`{`
		2325	`SEXP cell;`
		2326	`if (x == NULL \|\| x == R_NilValue \|\|`
		2327	`CDR(x) == NULL \|\| CDR(x) == R_NilValue \|\|`
		2328	`CDDR(x) == NULL \|\| CDDR(x) == R_NilValue)`
		2329	`error("bad value");`
		2330	`cell = CDDR(x);`
		2331	`CHECK_OLD_TO_NEW(cell, y);`
		2332	`CAR(cell) = y;`
		2333	`return y;`
		2334	`}`
		2335
		2336	`#define CDDDR(x) CDR(CDR(CDR(x)))`
		2337
		2338	`SEXP (SETCADDDR)(SEXP x, SEXP y)`
		2339	`{`
		2340	`SEXP cell;`
		2341	`if (x == NULL \|\| x == R_NilValue \|\|`
		2342	`CDR(x) == NULL \|\| CDR(x) == R_NilValue \|\|`
		2343	`CDDR(x) == NULL \|\| CDDR(x) == R_NilValue \|\|`
		2344	`CDDDR(x) == NULL \|\| CDDDR(x) == R_NilValue)`
		2345	`error("bad value");`
		2346	`cell = CDDDR(x);`
		2347	`CHECK_OLD_TO_NEW(cell, y);`
		2348	`CAR(cell) = y;`
		2349	`return y;`
		2350	`}`
		2351
		2352	`#define CD4R(x) CDR(CDR(CDR(CDR(x))))`
		2353
		2354	`SEXP (SETCAD4R)(SEXP x, SEXP y)`
		2355	`{`
		2356	`SEXP cell;`
		2357	`if (x == NULL \|\| x == R_NilValue \|\|`
		2358	`CDR(x) == NULL \|\| CDR(x) == R_NilValue \|\|`
		2359	`CDDR(x) == NULL \|\| CDDR(x) == R_NilValue \|\|`
		2360	`CDDDR(x) == NULL \|\| CDDDR(x) == R_NilValue \|\|`
		2361	`CD4R(x) == NULL \|\| CD4R(x) == R_NilValue)`
		2362	`error("bad value");`
		2363	`cell = CD4R(x);`
		2364	`CHECK_OLD_TO_NEW(cell, y);`
		2365	`CAR(cell) = y;`
		2366	`return y;`
		2367	`}`
		2368
		2369	`void (SET_MISSING)(SEXP x, int v) { SET_MISSING(x, v); }`
		2370
		2371	`/* Closure Accessors */`
		2372	`SEXP (FORMALS)(SEXP x) { return FORMALS(x); }`
		2373	`SEXP (BODY)(SEXP x) { return BODY(x); }`
		2374	`SEXP (CLOENV)(SEXP x) { return CLOENV(x); }`
		2375	`int (DEBUG)(SEXP x) { return DEBUG(x); }`
		2376	`int (TRACE)(SEXP x) { return TRACE(x); }`
		2377
		2378	`void (SET_FORMALS)(SEXP x, SEXP v) { CHECK_OLD_TO_NEW(x, v); FORMALS(x) = v; }`
		2379	`void (SET_BODY)(SEXP x, SEXP v) { CHECK_OLD_TO_NEW(x, v); BODY(x) = v; }`
		2380	`void (SET_CLOENV)(SEXP x, SEXP v) { CHECK_OLD_TO_NEW(x, v); CLOENV(x) = v; }`
		2381	`void (SET_DEBUG)(SEXP x, int v) { SET_DEBUG(x, v); }`
		2382	`void (SET_TRACE)(SEXP x, int v) { SET_TRACE(x, v); }`
		2383
		2384	`/* Primitive Accessors */`
		2385	`int (PRIMOFFSET)(SEXP x) { return PRIMOFFSET(x); }`
		2386
		2387	`void (SET_PRIMOFFSET)(SEXP x, int v) { SET_PRIMOFFSET(x, v); }`
		2388
		2389	`/* Symbol Accessors */`
		2390	`SEXP (PRINTNAME)(SEXP x) { return PRINTNAME(x); }`
		2391	`SEXP (SYMVALUE)(SEXP x) { return SYMVALUE(x); }`
		2392	`SEXP (INTERNAL)(SEXP x) { return INTERNAL(x); }`
		2393	`int (DDVAL)(SEXP x) { return DDVAL(x); }`
		2394
		2395	`void (SET_PRINTNAME)(SEXP x, SEXP v) { CHECK_OLD_TO_NEW(x, v); PRINTNAME(x) = v; }`
		2396	`void (SET_SYMVALUE)(SEXP x, SEXP v) { CHECK_OLD_TO_NEW(x, v); SYMVALUE(x) = v; }`
		2397	`void (SET_INTERNAL)(SEXP x, SEXP v) { CHECK_OLD_TO_NEW(x, v); INTERNAL(x) = v; }`
		2398	`void (SET_DDVAL)(SEXP x, int v) { SET_DDVAL(x, v); }`
		2399
		2400	`/* Environment Accessors */`
		2401	`SEXP (FRAME)(SEXP x) { return FRAME(x); }`
		2402	`SEXP (ENCLOS)(SEXP x) { return ENCLOS(x); }`
		2403	`SEXP (HASHTAB)(SEXP x) { return HASHTAB(x); }`
10383	luke	2404	`int (ENVFLAGS)(SEXP x) { return ENVFLAGS(x); }`
10172	luke	2405
		2406	`void (SET_FRAME)(SEXP x, SEXP v) { CHECK_OLD_TO_NEW(x, v); FRAME(x) = v; }`
		2407	`void (SET_ENCLOS)(SEXP x, SEXP v) { CHECK_OLD_TO_NEW(x, v); ENCLOS(x) = v; }`
		2408	`void (SET_HASHTAB)(SEXP x, SEXP v) { CHECK_OLD_TO_NEW(x, v); HASHTAB(x) = v; }`
10383	luke	2409	`void (SET_ENVFLAGS)(SEXP x, int v) { SET_ENVFLAGS(x, v); }`
10172	luke	2410
		2411	`/* Promise Accessors */`
26020	luke	2412	`SEXP (PRCODE)(SEXP x) { return PRCODE(x); }`
10172	luke	2413	`SEXP (PRENV)(SEXP x) { return PRENV(x); }`
		2414	`SEXP (PRVALUE)(SEXP x) { return PRVALUE(x); }`
		2415	`int (PRSEEN)(SEXP x) { return PRSEEN(x); }`
		2416
		2417	`void (SET_PRENV)(SEXP x, SEXP v){ CHECK_OLD_TO_NEW(x, v); PRENV(x) = v; }`
		2418	`void (SET_PRVALUE)(SEXP x, SEXP v) { CHECK_OLD_TO_NEW(x, v); PRVALUE(x) = v; }`
		2419	`void (SET_PRSEEN)(SEXP x, int v) { SET_PRSEEN(x, v); }`
		2420
		2421	`/* Hashing Accessors */`
		2422	`int (HASHASH)(SEXP x) { return HASHASH(x); }`
		2423	`int (HASHVALUE)(SEXP x) { return HASHVALUE(x); }`
		2424
		2425	`void (SET_HASHASH)(SEXP x, int v) { SET_HASHASH(x, v); }`
		2426	`void (SET_HASHVALUE)(SEXP x, int v) { SET_HASHVALUE(x, v); }`

The R Project SVN R

(root)/branches/R-Win-CMD/src/main/memory.c – Rev 28362