/
envir.c
4426 lines (3796 loc) · 120 KB
/
envir.c
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
/*
* R : A Computer Language for Statistical Data Analysis
* Copyright (C) 1999--2021 The R Core Team.
* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, a copy is available at
* https://www.R-project.org/Licenses/
*
*
*
* Environments:
*
* All the action of associating values with symbols happens
* in this code. An environment is (essentially) a list of
* environment "frames" of the form
*
* FRAME(envir) = environment frame
* ENCLOS(envir) = parent environment
* HASHTAB(envir) = (optional) hash table
*
* Each frame is a (tagged) list with
*
* TAG(item) = symbol
* CAR(item) = value bound to symbol in this frame
* CDR(item) = next value on the list
*
* When the value of a symbol is required, the environment is
* traversed frame-by-frame until a value is found.
*
* If a value is not found during the traversal, the symbol's
* "value" slot is inspected for a value. This "top-level"
* environment is where system functions and variables reside.
*
* Environments with the NO_SPECIAL_SYMBOLS flag set are known to not
* contain any special symbols, as indicated by the IS_SPECIAL_SYMBOL
* macro. Lookup for such a symbol can then bypass this environment
* without searching it.
*/
/* R 1.8.0: namespaces are no longer experimental, so the following
* are no longer 'experimental options', but rather three sections
* describing the API:
*
* NAMESPACES:
* R_BaseNamespace holds an environment that has R_GlobalEnv as
* its parent. This environment does not actually contain any
* bindings of its own. Instead, it redirects all fetches and
* assignments to the SYMVALUE fields of the base (R_BaseEnv)
* environment. If evaluation occurs in R_BaseNamespace, then
* base is searched before R_GlobalEnv.
*
* ENVIRONMENT_LOCKING: Locking an environment prevents new bindings
* from being created and existing bindings from being removed.
*
* FANCY_BINDINGS: We have binding locking and "active bindings".
* When a binding is locked, its value cannot be changed. It may
* still be removed from the environment if the environment is not
* locked.
*
* Active bindings contain a function in their value cell.
* Getting the value of an active binding calls this function with
* no arguments and returns the result. Assigning to an active
* binding calls this function with one argument, the new value.
* Active bindings may be useful for mapping external variables,
* such as C variables or data base entries, to R variables. They
* may also be useful for making some globals thread-safe.
*
* Bindings are marked as locked or active using bits 14 and 15 in
* their gp fields. Since the save/load code writes out this
* field it means the value will be preserved across save/load.
* But older versions of R will interpret the entire gp field as
* the MISSING field, which may cause confusion. If we keep this
* code, then we will need to make sure that there are no
* locked/active bindings in workspaces written for older versions
* of R to read.
*
* LT */
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#define R_USE_SIGNALS 1
#include <Defn.h>
#include <Internal.h>
#include <R_ext/Callbacks.h>
#define FAST_BASE_CACHE_LOOKUP /* Define to enable fast lookups of symbols */
/* in global cache from base environment */
#define IS_USER_DATABASE(rho) (OBJECT((rho)) && inherits((rho), "UserDefinedDatabase"))
/* various definitions of macros/functions in Defn.h */
#define FRAME_LOCK_MASK (1<<14)
#define FRAME_IS_LOCKED(e) (ENVFLAGS(e) & FRAME_LOCK_MASK)
#define LOCK_FRAME(e) SET_ENVFLAGS(e, ENVFLAGS(e) | FRAME_LOCK_MASK)
/*#define UNLOCK_FRAME(e) SET_ENVFLAGS(e, ENVFLAGS(e) & (~ FRAME_LOCK_MASK))*/
/* use the same bits (15 and 14) in symbols and bindings */
static SEXP getActiveValue(SEXP);
static R_INLINE SEXP BINDING_VALUE(SEXP b)
{
if (BNDCELL_TAG(b)) {
R_expand_binding_value(b);
return CAR0(b);
}
if (IS_ACTIVE_BINDING(b)) return getActiveValue(CAR(b));
else return CAR(b);
}
#define SYMBOL_BINDING_VALUE(s) ((IS_ACTIVE_BINDING(s) ? getActiveValue(SYMVALUE(s)) : SYMVALUE(s)))
#define SYMBOL_HAS_BINDING(s) (IS_ACTIVE_BINDING(s) || (SYMVALUE(s) != R_UnboundValue))
#define SET_BINDING_VALUE(b,val) do { \
SEXP __b__ = (b); \
SEXP __val__ = (val); \
if (BINDING_IS_LOCKED(__b__)) \
error(_("cannot change value of locked binding for '%s'"), \
CHAR(PRINTNAME(TAG(__b__)))); \
if (IS_ACTIVE_BINDING(__b__)) { \
PROTECT(__val__); \
setActiveValue(CAR(__b__), __val__); \
UNPROTECT(1); \
} else \
SET_BNDCELL(__b__, __val__); \
} while (0)
#define SET_SYMBOL_BINDING_VALUE(sym, val) do { \
SEXP __sym__ = (sym); \
SEXP __val__ = (val); \
if (BINDING_IS_LOCKED(__sym__)) \
error(_("cannot change value of locked binding for '%s'"), \
CHAR(PRINTNAME(__sym__))); \
if (IS_ACTIVE_BINDING(__sym__)) { \
PROTECT(__val__); \
setActiveValue(SYMVALUE(__sym__), __val__); \
UNPROTECT(1); \
} else \
SET_SYMVALUE(__sym__, __val__); \
} while (0)
static void setActiveValue(SEXP fun, SEXP val)
{
SEXP qfun = lang3(R_DoubleColonSymbol, R_BaseSymbol, R_QuoteSymbol);
SEXP arg = lang2(qfun, val);
SEXP expr = lang2(fun, arg);
PROTECT(expr);
eval(expr, R_GlobalEnv);
UNPROTECT(1);
}
static SEXP getActiveValue(SEXP fun)
{
SEXP expr = LCONS(fun, R_NilValue);
PROTECT(expr);
expr = eval(expr, R_GlobalEnv);
UNPROTECT(1);
return expr;
}
/* Macro version of isNull for only the test against R_NilValue */
#define ISNULL(x) ((x) == R_NilValue)
/* Function to determine whethr an environment contains special symbols */
Rboolean R_envHasNoSpecialSymbols (SEXP env)
{
SEXP frame;
if (HASHTAB(env) != R_NilValue)
return FALSE;
for (frame = FRAME(env); frame != R_NilValue; frame = CDR(frame))
if (IS_SPECIAL_SYMBOL(TAG(frame)))
return FALSE;
return TRUE;
}
/*----------------------------------------------------------------------
Hash Tables
We use a basic separate chaining algorithm. A hash table consists
of SEXP (vector) which contains a number of SEXPs (lists).
The only non-static function is R_NewHashedEnv, which allows code to
request a hashed environment. All others are static to allow
internal changes of implementation without affecting client code.
*/
#define HASHSIZE(x) ((int) STDVEC_LENGTH(x))
#define HASHPRI(x) ((int) STDVEC_TRUELENGTH(x))
#define HASHTABLEGROWTHRATE 1.2
#define HASHMINSIZE 29
#define SET_HASHPRI(x,v) SET_TRUELENGTH(x,v)
#define HASHCHAIN(table, i) ((SEXP *) STDVEC_DATAPTR(table))[i]
#define IS_HASHED(x) (HASHTAB(x) != R_NilValue)
/*----------------------------------------------------------------------
String Hashing
This is taken from the second edition of the "Dragon Book" by
Aho, Ullman and Sethi.
*/
/* was extern: used in this file and names.c (for the symbol table).
This hash function seems to work well enough for symbol tables,
and hash tables get saved as part of environments so changing it
is a major decision.
*/
int attribute_hidden R_Newhashpjw(const char *s)
{
char *p;
unsigned h = 0, g;
for (p = (char *) s; *p; p++) {
h = (h << 4) + (*p);
if ((g = h & 0xf0000000) != 0) {
h = h ^ (g >> 24);
h = h ^ g;
}
}
return h;
}
/*----------------------------------------------------------------------
R_HashSet
Hashtable set function. Sets 'symbol' in 'table' to be 'value'.
'hashcode' must be provided by user. Allocates some memory for list
entries.
*/
static void R_HashSet(int hashcode, SEXP symbol, SEXP table, SEXP value,
Rboolean frame_locked)
{
SEXP chain;
/* Grab the chain from the hashtable */
chain = VECTOR_ELT(table, hashcode);
/* Search for the value in the chain */
for (; !ISNULL(chain); chain = CDR(chain))
if (TAG(chain) == symbol) {
SET_BINDING_VALUE(chain, value);
SET_MISSING(chain, 0); /* Over-ride for new value */
return;
}
if (frame_locked)
error(_("cannot add bindings to a locked environment"));
if (ISNULL(chain))
SET_HASHPRI(table, HASHPRI(table) + 1);
/* Add the value into the chain */
SET_VECTOR_ELT(table, hashcode, CONS(value, VECTOR_ELT(table, hashcode)));
SET_TAG(VECTOR_ELT(table, hashcode), symbol);
return;
}
/*----------------------------------------------------------------------
R_HashGet
Hashtable get function. Returns 'value' from 'table' indexed by
'symbol'. 'hashcode' must be provided by user. Returns
'R_UnboundValue' if value is not present.
*/
static SEXP R_HashGet(int hashcode, SEXP symbol, SEXP table)
{
SEXP chain;
/* Grab the chain from the hashtable */
chain = HASHCHAIN(table, hashcode);
/* Retrieve the value from the chain */
for (; chain != R_NilValue ; chain = CDR(chain))
if (TAG(chain) == symbol) return BINDING_VALUE(chain);
/* If not found */
return R_UnboundValue;
}
static Rboolean R_HashExists(int hashcode, SEXP symbol, SEXP table)
{
SEXP chain;
/* Grab the chain from the hashtable */
chain = VECTOR_ELT(table, hashcode);
/* Find the binding in the chain */
for (; chain != R_NilValue ; chain = CDR(chain))
if (TAG(chain) == symbol) return TRUE;
/* If not found */
return FALSE;
}
/*----------------------------------------------------------------------
R_HashGetLoc
Hashtable get location function. Just like R_HashGet, but returns
location of variable, rather than its value. Returns R_NilValue
if not found.
*/
static SEXP R_HashGetLoc(int hashcode, SEXP symbol, SEXP table)
{
SEXP chain;
/* Grab the chain from the hashtable */
chain = VECTOR_ELT(table, hashcode);
/* Retrieve the value from the chain */
for (; !ISNULL(chain); chain = CDR(chain))
if (TAG(chain) == symbol) return chain;
/* If not found */
return R_NilValue;
}
/*----------------------------------------------------------------------
R_NewHashTable
Hash table initialisation function. Creates a table of size 'size'
that increases in size by 'growth_rate' after a threshold is met.
*/
static SEXP R_NewHashTable(int size)
{
SEXP table;
if (size <= 0) size = HASHMINSIZE;
/* Allocate hash table in the form of a vector */
PROTECT(table = allocVector(VECSXP, size));
SET_HASHPRI(table, 0);
UNPROTECT(1);
return(table);
}
/*----------------------------------------------------------------------
R_NewHashedEnv
Returns a new environment with a hash table initialized with default
size. The only non-static hash table function.
*/
SEXP R_NewHashedEnv(SEXP enclos, SEXP size)
{
SEXP s;
PROTECT(enclos);
PROTECT(size);
PROTECT(s = NewEnvironment(R_NilValue, R_NilValue, enclos));
SET_HASHTAB(s, R_NewHashTable(asInteger(size)));
UNPROTECT(3);
return s;
}
/*----------------------------------------------------------------------
R_HashDelete
Hash table delete function. Symbols are completely removed from the table;
there is no way to mark a symbol as not present without actually removing
it.
*/
static SEXP RemoveFromList(SEXP thing, SEXP list, int *found);
static void R_HashDelete(int hashcode, SEXP symbol, SEXP env, int *found)
{
int idx;
SEXP list, hashtab;
hashtab = HASHTAB(env);
idx = hashcode % HASHSIZE(hashtab);
list = RemoveFromList(symbol, VECTOR_ELT(hashtab, idx), found);
if (*found) {
if (env == R_GlobalEnv)
R_DirtyImage = 1;
if (list == R_NilValue)
SET_HASHPRI(hashtab, HASHPRI(hashtab) - 1);
SET_VECTOR_ELT(hashtab, idx, list);
}
}
/*----------------------------------------------------------------------
R_HashResize
Hash table resizing function Increase the size of the hash table by
the growth_rate of the table. The vector is reallocated, however
the lists with in the hash table have their pointers shuffled around
so that they are not reallocated.
*/
static SEXP R_HashResize(SEXP table)
{
SEXP new_table, chain, new_chain, tmp_chain;
int counter, new_hashcode;
/* Do some checking */
if (TYPEOF(table) != VECSXP)
error("first argument ('table') not of type VECSXP, from R_HashResize");
/* This may have to change. The growth rate should
be independent of the size (not implemented yet) */
/* hash_grow = HASHSIZE(table); */
/* Allocate the new hash table */
new_table = R_NewHashTable((int)(HASHSIZE(table) * HASHTABLEGROWTHRATE));
for (counter = 0; counter < length(table); counter++) {
chain = VECTOR_ELT(table, counter);
while (!ISNULL(chain)) {
new_hashcode = R_Newhashpjw(CHAR(PRINTNAME(TAG(chain)))) %
HASHSIZE(new_table);
new_chain = VECTOR_ELT(new_table, new_hashcode);
/* If using a primary slot then increase HASHPRI */
if (ISNULL(new_chain))
SET_HASHPRI(new_table, HASHPRI(new_table) + 1);
tmp_chain = chain;
chain = CDR(chain);
SETCDR(tmp_chain, new_chain);
SET_VECTOR_ELT(new_table, new_hashcode, tmp_chain);
#ifdef MIKE_DEBUG
fprintf(stdout, "HASHSIZE = %d\nHASHPRI = %d\ncounter = %d\nHASHCODE = %d\n",
HASHSIZE(table), HASHPRI(table), counter, new_hashcode);
#endif
}
}
/* Some debugging statements */
#ifdef MIKE_DEBUG
fprintf(stdout, "Resized O.K.\n");
fprintf(stdout, "Old size: %d, New size: %d\n",
HASHSIZE(table), HASHSIZE(new_table));
fprintf(stdout, "Old pri: %d, New pri: %d\n",
HASHPRI(table), HASHPRI(new_table));
#endif
return new_table;
} /* end R_HashResize */
/*----------------------------------------------------------------------
R_HashSizeCheck
Hash table size rechecking function. Compares the load factor
(size/# of primary slots used) to a particular threshhold value.
Returns true if the table needs to be resized.
*/
static int R_HashSizeCheck(SEXP table)
{
int resize;
double thresh_val;
/* Do some checking */
if (TYPEOF(table) != VECSXP)
error("first argument ('table') not of type VECSXP, R_HashSizeCheck");
resize = 0; thresh_val = 0.85;
if ((double)HASHPRI(table) > (double)HASHSIZE(table) * thresh_val)
resize = 1;
return resize;
}
/*----------------------------------------------------------------------
R_HashFrame
Hashing for environment frames. This function ensures that the
first frame in the given environment has been hashed. Ultimately
all enironments should be created in hashed form. At that point
this function will be redundant.
*/
static SEXP R_HashFrame(SEXP rho)
{
int hashcode;
SEXP frame, chain, tmp_chain, table;
/* Do some checking */
if (TYPEOF(rho) != ENVSXP)
error("first argument ('table') not of type ENVSXP, from R_HashVector2Hash");
table = HASHTAB(rho);
frame = FRAME(rho);
while (!ISNULL(frame)) {
if( !HASHASH(PRINTNAME(TAG(frame))) ) {
SET_HASHVALUE(PRINTNAME(TAG(frame)),
R_Newhashpjw(CHAR(PRINTNAME(TAG(frame)))));
SET_HASHASH(PRINTNAME(TAG(frame)), 1);
}
hashcode = HASHVALUE(PRINTNAME(TAG(frame))) % HASHSIZE(table);
chain = VECTOR_ELT(table, hashcode);
/* If using a primary slot then increase HASHPRI */
if (ISNULL(chain)) SET_HASHPRI(table, HASHPRI(table) + 1);
tmp_chain = frame;
frame = CDR(frame);
SETCDR(tmp_chain, chain);
SET_VECTOR_ELT(table, hashcode, tmp_chain);
}
SET_FRAME(rho, R_NilValue);
return rho;
}
/* ---------------------------------------------------------------------
R_HashProfile
Profiling tool for analyzing hash table performance. Returns a
three element list with components:
size: the total size of the hash table
nchains: the number of non-null chains in the table (as reported by
HASHPRI())
counts: an integer vector the same length as size giving the length of
each chain (or zero if no chain is present). This allows
for assessing collisions in the hash table.
*/
static SEXP R_HashProfile(SEXP table)
{
SEXP chain, ans, chain_counts, nms;
int i, count;
PROTECT(ans = allocVector(VECSXP, 3));
PROTECT(nms = allocVector(STRSXP, 3));
SET_STRING_ELT(nms, 0, mkChar("size")); /* size of hashtable */
SET_STRING_ELT(nms, 1, mkChar("nchains")); /* number of non-null chains */
SET_STRING_ELT(nms, 2, mkChar("counts")); /* length of each chain */
setAttrib(ans, R_NamesSymbol, nms);
UNPROTECT(1);
SET_VECTOR_ELT(ans, 0, ScalarInteger(length(table)));
SET_VECTOR_ELT(ans, 1, ScalarInteger(HASHPRI(table)));
PROTECT(chain_counts = allocVector(INTSXP, length(table)));
for (i = 0; i < length(table); i++) {
chain = VECTOR_ELT(table, i);
count = 0;
for (; chain != R_NilValue ; chain = CDR(chain)) {
count++;
}
INTEGER(chain_counts)[i] = count;
}
SET_VECTOR_ELT(ans, 2, chain_counts);
UNPROTECT(2);
return ans;
}
/*----------------------------------------------------------------------
Environments
The following code implements variable searching for environments.
*/
/*----------------------------------------------------------------------
InitGlobalEnv
Create the initial global environment. The global environment is
no longer a linked list of environment frames. Instead it is a
vector of environments which is searched from beginning to end.
Note that only the first frame of each of these environments is
searched. This is intended to make it possible to implement
namespaces at some (indeterminate) point in the future.
We hash the initial environment. 100 is a magic number discovered
by Ross. Change it if you feel inclined.
*/
#define USE_GLOBAL_CACHE
#ifdef USE_GLOBAL_CACHE /* NB leave in place: see below */
/* Global variable caching. A cache is maintained in a hash table,
R_GlobalCache. The entry values are either R_UnboundValue (a
flushed cache entry), the binding LISTSXP cell from the environment
containing the binding found in a search from R_GlobalEnv, or a
symbol if the globally visible binding lives in the base package.
The cache for a variable is flushed if a new binding for it is
created in a global frame or if the variable is removed from any
global frame.
Symbols in the global cache with values from the base environment
are flagged with BASE_SYM_CACHED, so that their value can be
returned immediately without needing to look in the hash table.
They must still have entries in the hash table, however, so that
they can be flushed as needed.
To make sure the cache is valid, all binding creations and removals
from global frames must go through the interface functions in this
file.
Initially only the R_GlobalEnv frame is a global frame. Additional
global frames can only be created by attach. All other frames are
considered local. Whether a frame is local or not is recorded in
the highest order bit of the ENVFLAGS field (the gp field of
sxpinfo).
It is possible that the benefit of caching may be significantly
reduced if we introduce namespace management. Since maintaining
cache integrity is a bit tricky and since it might complicate
threading a bit (I'm not sure it will but it needs to be thought
through if nothing else) it might make sense to remove caching at
that time. To make that easier, the ifdef's should probably be
left in place.
L. T. */
#define GLOBAL_FRAME_MASK (1<<15)
#define IS_GLOBAL_FRAME(e) (ENVFLAGS(e) & GLOBAL_FRAME_MASK)
#define MARK_AS_GLOBAL_FRAME(e) \
SET_ENVFLAGS(e, ENVFLAGS(e) | GLOBAL_FRAME_MASK)
#define MARK_AS_LOCAL_FRAME(e) \
SET_ENVFLAGS(e, ENVFLAGS(e) & (~ GLOBAL_FRAME_MASK))
#define INITIAL_CACHE_SIZE 1000
static SEXP R_GlobalCache, R_GlobalCachePreserve;
#endif
static SEXP R_BaseNamespaceName;
static SEXP R_NamespaceSymbol;
void attribute_hidden InitBaseEnv()
{
R_EmptyEnv = NewEnvironment(R_NilValue, R_NilValue, R_NilValue);
R_BaseEnv = NewEnvironment(R_NilValue, R_NilValue, R_EmptyEnv);
}
void attribute_hidden InitGlobalEnv()
{
R_NamespaceSymbol = install(".__NAMESPACE__.");
R_GlobalEnv = R_NewHashedEnv(R_BaseEnv, ScalarInteger(0));
R_MethodsNamespace = R_GlobalEnv; // so it is initialized.
#ifdef NEW_CODE /* Not used */
HASHTAB(R_GlobalEnv) = R_NewHashTable(100);
#endif
#ifdef USE_GLOBAL_CACHE
MARK_AS_GLOBAL_FRAME(R_GlobalEnv);
R_GlobalCache = R_NewHashTable(INITIAL_CACHE_SIZE);
R_GlobalCachePreserve = CONS(R_GlobalCache, R_NilValue);
R_PreserveObject(R_GlobalCachePreserve);
#endif
R_BaseNamespace = NewEnvironment(R_NilValue, R_NilValue, R_GlobalEnv);
R_PreserveObject(R_BaseNamespace);
SET_SYMVALUE(install(".BaseNamespaceEnv"), R_BaseNamespace);
R_BaseNamespaceName = ScalarString(mkChar("base"));
R_PreserveObject(R_BaseNamespaceName);
R_NamespaceRegistry = R_NewHashedEnv(R_NilValue, ScalarInteger(0));
R_PreserveObject(R_NamespaceRegistry);
defineVar(R_BaseSymbol, R_BaseNamespace, R_NamespaceRegistry);
/**** needed to properly initialize the base namespace */
}
#ifdef USE_GLOBAL_CACHE
static int hashIndex(SEXP symbol, SEXP table)
{
SEXP c = PRINTNAME(symbol);
if( !HASHASH(c) ) {
SET_HASHVALUE(c, R_Newhashpjw(CHAR(c)));
SET_HASHASH(c, 1);
}
return HASHVALUE(c) % HASHSIZE(table);
}
static void R_FlushGlobalCache(SEXP sym)
{
SEXP entry = R_HashGetLoc(hashIndex(sym, R_GlobalCache), sym,
R_GlobalCache);
if (entry != R_NilValue) {
SETCAR(entry, R_UnboundValue);
#ifdef FAST_BASE_CACHE_LOOKUP
UNSET_BASE_SYM_CACHED(sym);
#endif
}
}
static void R_FlushGlobalCacheFromTable(SEXP table)
{
int i, size;
SEXP chain;
size = HASHSIZE(table);
for (i = 0; i < size; i++) {
for (chain = VECTOR_ELT(table, i); chain != R_NilValue; chain = CDR(chain))
R_FlushGlobalCache(TAG(chain));
}
}
/**
Flush the cache based on the names provided by the user defined
table, specifically returned from calling objects() for that
table.
*/
static void R_FlushGlobalCacheFromUserTable(SEXP udb)
{
int n, i;
R_ObjectTable *tb;
SEXP names;
tb = (R_ObjectTable*) R_ExternalPtrAddr(udb);
names = tb->objects(tb);
n = length(names);
for(i = 0; i < n ; i++)
R_FlushGlobalCache(Rf_installTrChar(STRING_ELT(names,i)));
}
static void R_AddGlobalCache(SEXP symbol, SEXP place)
{
int oldpri = HASHPRI(R_GlobalCache);
R_HashSet(hashIndex(symbol, R_GlobalCache), symbol, R_GlobalCache, place,
FALSE);
#ifdef FAST_BASE_CACHE_LOOKUP
if (symbol == place)
SET_BASE_SYM_CACHED(symbol);
else
UNSET_BASE_SYM_CACHED(symbol);
#endif
if (oldpri != HASHPRI(R_GlobalCache) &&
HASHPRI(R_GlobalCache) > 0.85 * HASHSIZE(R_GlobalCache)) {
R_GlobalCache = R_HashResize(R_GlobalCache);
SETCAR(R_GlobalCachePreserve, R_GlobalCache);
}
}
static SEXP R_GetGlobalCacheLoc(SEXP symbol)
{
#ifdef FAST_BASE_CACHE_LOOKUP
if (BASE_SYM_CACHED(symbol))
return symbol;
#endif
return R_HashGet(hashIndex(symbol, R_GlobalCache), symbol, R_GlobalCache);
}
#endif /* USE_GLOBAL_CACHE */
/*----------------------------------------------------------------------
unbindVar
Remove a value from an environment. This happens only in the frame
of the specified environment.
FIXME ? should this also unbind the symbol value slot when rho is
R_BaseEnv.
This is only called from eval.c in applydefine and bcEval
(and applydefine only works for unhashed environments, so not base).
*/
static SEXP RemoveFromList(SEXP thing, SEXP list, int *found)
{
if (list == R_NilValue) {
*found = 0;
return R_NilValue;
}
else if (TAG(list) == thing) {
*found = 1;
SET_BNDCELL(list, R_UnboundValue); /* in case binding is cached */
LOCK_BINDING(list); /* in case binding is cached */
SEXP rest = CDR(list);
SETCDR(list, R_NilValue); /* to fix refcnt on 'rest' */
return rest;
}
else {
SEXP last = list;
SEXP next = CDR(list);
while (next != R_NilValue) {
if (TAG(next) == thing) {
*found = 1;
SETCAR(next, R_UnboundValue); /* in case binding is cached */
LOCK_BINDING(next); /* in case binding is cached */
SETCDR(last, CDR(next));
SETCDR(next, R_NilValue); /* to fix refcnt on 'list' */
return list;
}
else {
last = next;
next = CDR(next);
}
}
*found = 0;
return list;
}
}
void attribute_hidden unbindVar(SEXP symbol, SEXP rho)
{
int hashcode;
int found;
SEXP c;
if (rho == R_BaseNamespace)
error(_("cannot unbind in the base namespace"));
if (rho == R_BaseEnv)
error(_("unbind in the base environment is unimplemented"));
if (FRAME_IS_LOCKED(rho))
error(_("cannot remove bindings from a locked environment"));
if (HASHTAB(rho) == R_NilValue) {
SEXP list;
list = RemoveFromList(symbol, FRAME(rho), &found);
if (found) {
if (rho == R_GlobalEnv) R_DirtyImage = 1;
SET_FRAME(rho, list);
#ifdef USE_GLOBAL_CACHE
if (IS_GLOBAL_FRAME(rho))
R_FlushGlobalCache(symbol);
#endif
}
}
else {
/* This branch is used e.g. via sys.source, utils::data */
c = PRINTNAME(symbol);
if( !HASHASH(c) ) {
SET_HASHVALUE(c, R_Newhashpjw(CHAR(c)));
SET_HASHASH(c, 1);
}
hashcode = HASHVALUE(c) % HASHSIZE(HASHTAB(rho));
R_HashDelete(hashcode, symbol, rho, &found);
#ifdef USE_GLOBAL_CACHE
if (found && IS_GLOBAL_FRAME(rho))
R_FlushGlobalCache(symbol);
#endif
}
}
/*----------------------------------------------------------------------
findVarLocInFrame
Look up the location of the value of a symbol in a
single environment frame. Almost like findVarInFrame, but
does not return the value. R_NilValue if not found.
Callers set *canCache = TRUE or NULL
*/
static SEXP findVarLocInFrame(SEXP rho, SEXP symbol, Rboolean *canCache)
{
int hashcode;
SEXP frame, c;
if (rho == R_BaseEnv || rho == R_BaseNamespace)
return (SYMVALUE(symbol) == R_UnboundValue) ? R_NilValue : symbol;
if (rho == R_EmptyEnv)
return R_NilValue;
if(IS_USER_DATABASE(rho)) {
R_ObjectTable *table;
SEXP val, tmp = R_NilValue;
table = (R_ObjectTable *) R_ExternalPtrAddr(HASHTAB(rho));
/* Better to use exists() here if we don't actually need the value! */
val = table->get(CHAR(PRINTNAME(symbol)), canCache, table);
if(val != R_UnboundValue) {
/* The result should probably be identified as being from
a user database, or maybe use an active binding
mechanism to allow setting a new value to get back to
the data base. */
tmp = allocSExp(LISTSXP);
SETCAR(tmp, val);
SET_TAG(tmp, symbol);
/* If the database has a canCache method, then call that.
Otherwise, we believe the setting for canCache. */
if(canCache && table->canCache) {
PROTECT(tmp);
*canCache = table->canCache(CHAR(PRINTNAME(symbol)), table);
UNPROTECT(1);
}
MARK_NOT_MUTABLE(val); /* to keep complex assignment code sane */
}
return(tmp);
}
if (HASHTAB(rho) == R_NilValue) {
frame = FRAME(rho);
while (frame != R_NilValue && TAG(frame) != symbol)
frame = CDR(frame);
return frame;
}
else {
c = PRINTNAME(symbol);
if( !HASHASH(c) ) {
SET_HASHVALUE(c, R_Newhashpjw(CHAR(c)));
SET_HASHASH(c, 1);
}
hashcode = HASHVALUE(c) % HASHSIZE(HASHTAB(rho));
/* Will return 'R_NilValue' if not found */
return R_HashGetLoc(hashcode, symbol, HASHTAB(rho));
}
}
/*
External version and accessor functions. Returned value is cast as
an opaque pointer to insure it is only used by routines in this
group. This allows the implementation to be changed without needing
to change other files.
*/
R_varloc_t R_findVarLocInFrame(SEXP rho, SEXP symbol)
{
SEXP binding = findVarLocInFrame(rho, symbol, NULL);
R_varloc_t val;
val.cell = binding == R_NilValue ? NULL : binding;
return val;
}
attribute_hidden
SEXP R_GetVarLocValue(R_varloc_t vl)
{
SEXP cell = vl.cell;
if (cell == NULL || cell == R_UnboundValue)
return R_UnboundValue;
else if (TYPEOF(cell) == SYMSXP)
return SYMBOL_BINDING_VALUE(cell);
else return BINDING_VALUE(cell);
}
attribute_hidden
SEXP R_GetVarLocSymbol(R_varloc_t vl)
{
return TAG(vl.cell);
}
/* used in methods */
Rboolean R_GetVarLocMISSING(R_varloc_t vl)
{
return MISSING(vl.cell);
}
attribute_hidden
void R_SetVarLocValue(R_varloc_t vl, SEXP value)
{
SET_BINDING_VALUE(vl.cell, value);
}
/*----------------------------------------------------------------------
findVarInFrame
Look up the value of a symbol in a single environment frame. This
is the basic building block of all variable lookups.
It is important that this be as efficient as possible.
The final argument is usually TRUE and indicates whether the
lookup is being done in order to get the value (TRUE) or
simply to check whether there is a value bound to the specified
symbol in this frame (FALSE). This is used for get() and exists().
*/
SEXP findVarInFrame3(SEXP rho, SEXP symbol, Rboolean doGet)
{
int hashcode;