1 /*
2 * R : A Computer Language for Statistical Data Analysis
3 * Copyright (C) 2000-2014 The R Core Team
4 *
5 * This program is free software; you can redistribute it and/or modify
6 * it under the terms of the GNU General Public License as published by
7 * the Free Software Foundation; either version 2 of the License, or
8 * (at your option) any later version.
9 *
10 * This program is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
14 *
15 * You should have received a copy of the GNU General Public License
16 * along with this program; if not, a copy is available at
17 * https://www.R-project.org/Licenses/
18 */
19
20
21 /* We need to know the sizes of certain internal structures */
22 #define USE_RINTERNALS
23
24 #ifdef HAVE_CONFIG_H
25 #include <config.h>
26 #endif
27
28 #include <Defn.h>
29
30 /* A count of the memory used by an object. The following assumptions
31 are made.
32
33 1) this is called from user-level, so only some types of objects are
34 important.
35 2) an object gets charged for all the space allocated on the heap
36 and all the nodes specifically due to it, but not for the
37 space for its name nor for .Internals it references.
38 */
39 SEXP Rf_csduplicated(SEXP x); /* from unique.c */
40
objectsize(SEXP s)41 static R_size_t objectsize(SEXP s)
42 {
43 R_size_t cnt = 0, vcnt = 0;
44 SEXP tmp, dup;
45 Rboolean isVec = FALSE;
46
47 switch (TYPEOF(s)) {
48 case NILSXP:
49 return(0);
50 break;
51 case SYMSXP:
52 break;
53 case LISTSXP:
54 case LANGSXP:
55 case BCODESXP:
56 case DOTSXP:
57 R_CheckStack();
58 for (Rboolean done = FALSE; ! done; ) {
59 cnt += objectsize(TAG(s));
60 cnt += objectsize(CAR(s));
61 cnt += sizeof(SEXPREC);
62 cnt += objectsize(ATTRIB(s));
63 s = CDR(s);
64 switch (TYPEOF(s)) {
65 case LISTSXP:
66 case LANGSXP:
67 case BCODESXP:
68 case DOTSXP: break;
69 case NILSXP: return cnt;
70 default: done = TRUE;
71 }
72 }
73 cnt += objectsize(s);
74 break;
75 case CLOSXP:
76 R_CheckStack();
77 cnt += objectsize(FORMALS(s));
78 cnt += objectsize(BODY(s));
79 /* no charge for the environment */
80 break;
81 case ENVSXP:
82 R_CheckStack(); /* in case attributes might lead to a cycle */
83 case PROMSXP:
84 case SPECIALSXP:
85 case BUILTINSXP:
86 break;
87 case CHARSXP:
88 vcnt = BYTE2VEC(length(s)+1);
89 isVec = TRUE;
90 break;
91 case LGLSXP:
92 case INTSXP:
93 vcnt = INT2VEC(xlength(s));
94 isVec = TRUE;
95 break;
96 case REALSXP:
97 vcnt = FLOAT2VEC(xlength(s));
98 isVec = TRUE;
99 break;
100 case CPLXSXP:
101 vcnt = COMPLEX2VEC(xlength(s));
102 isVec = TRUE;
103 break;
104 case STRSXP:
105 R_CheckStack();
106 vcnt = PTR2VEC(xlength(s));
107 PROTECT(dup = Rf_csduplicated(s));
108 for (R_xlen_t i = 0; i < xlength(s); i++) {
109 tmp = STRING_ELT(s, i);
110 if(tmp != NA_STRING && !LOGICAL(dup)[i])
111 cnt += objectsize(tmp);
112 }
113 isVec = TRUE;
114 UNPROTECT(1);
115 break;
116 case ANYSXP:
117 /* we don't know about these */
118 break;
119 case VECSXP:
120 case EXPRSXP:
121 case WEAKREFSXP:
122 /* Generic Vector Objects */
123 R_CheckStack();
124 vcnt = PTR2VEC(xlength(s));
125 for (R_xlen_t i = 0; i < xlength(s); i++)
126 cnt += objectsize(VECTOR_ELT(s, i));
127 isVec = TRUE;
128 break;
129 case EXTPTRSXP:
130 R_CheckStack();
131 cnt += sizeof(void *); /* the actual pointer */
132 cnt += objectsize(EXTPTR_PROT(s));
133 cnt += objectsize(EXTPTR_TAG(s));
134 break;
135 case RAWSXP:
136 vcnt = BYTE2VEC(xlength(s));
137 isVec = TRUE;
138 break;
139 case S4SXP:
140 /* Has TAG and ATRIB but no CAR nor CDR */
141 R_CheckStack();
142 cnt += objectsize(TAG(s));
143 break;
144 default:
145 UNIMPLEMENTED_TYPE("object.size", s);
146 }
147 /* add in node space:
148 we need to take into account the rounding up that goes on
149 in the node classes. */
150 if(isVec) {
151 cnt += sizeof(SEXPREC_ALIGN);
152 if (vcnt > 16) cnt += 8*vcnt;
153 else if (vcnt > 8) cnt += 128;
154 else if (vcnt > 6) cnt += 64;
155 else if (vcnt > 4) cnt += 48;
156 else if (vcnt > 2) cnt += 32;
157 else if (vcnt > 1) cnt += 16;
158 else if (vcnt > 0) cnt += 8;
159 } else cnt += sizeof(SEXPREC);
160 /* add in attributes: these are fake for CHARSXPs */
161 if(TYPEOF(s) != CHARSXP) cnt += objectsize(ATTRIB(s));
162 return(cnt);
163 }
164
165
objectSize(SEXP x)166 SEXP objectSize(SEXP x)
167 {
168 return ScalarReal( (double) objectsize(x) );
169 }
170