1 /* intern.c
2 * Copyright 1984-2017 Cisco Systems, Inc.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 */
16
17 #include "system.h"
18
19 /* locally defined functions */
20 static void oblist_insert PROTO((ptr sym, iptr idx, IGEN g));
21 static iptr hash PROTO((const unsigned char *s, iptr n));
22 static iptr hash_sc PROTO((const string_char *s, iptr n));
23 static iptr hash_uname PROTO((const string_char *s, iptr n));
24 static ptr mkstring PROTO((const string_char *s, iptr n));
25
26 #define OBINDEX(hc, len) ((hc) & ((len) - 1))
27 #define MIN_OBLIST_LENGTH 4096
28
S_intern_init()29 void S_intern_init() {
30 IGEN g;
31
32 if (!S_boot_time) return;
33
34 S_G.oblist_length = MIN_OBLIST_LENGTH;
35 S_G.oblist_count = 0;
36 S_G.oblist = S_getmem(S_G.oblist_length * sizeof(bucket *), 1, 0);
37 for (g = 0; g < static_generation; g += 1) S_G.buckets_of_generation[g] = NULL;
38 }
39
oblist_insert(ptr sym,iptr idx,IGEN g)40 static void oblist_insert(ptr sym, iptr idx, IGEN g) {
41 ptr tc = get_thread_context();
42 bucket *b, *oldb, **pb;
43
44 find_room_voidp(tc, g == 0 ? space_new : space_data, g, ptr_align(sizeof(bucket)), b);
45 b->sym = sym;
46 if (g == 0) {
47 b->next = S_G.oblist[idx];
48 S_G.oblist[idx] = b;
49 } else {
50 for (pb = &S_G.oblist[idx]; (oldb = *pb) != NULL && SegmentGeneration(addr_get_segment(TO_PTR(oldb))) < g; pb = &oldb->next);
51 b->next = oldb;
52 *pb = b;
53 }
54
55 if (g != static_generation) {
56 bucket_list *bl;
57 find_room_voidp(tc, g == 0 ? space_new : space_data, g, ptr_align(sizeof(bucket_list)), bl);
58 bl->car = b;
59 bl->cdr = S_G.buckets_of_generation[g];
60 S_G.buckets_of_generation[g] = bl;
61 }
62
63 S_G.oblist_count += 1;
64 }
65
S_resize_oblist(void)66 void S_resize_oblist(void) {
67 bucket **new_oblist, *b, *oldb, **pb, *bnext;
68 iptr new_oblist_length, i, idx, inc = 0, dinc = 0;
69 ptr sym;
70 IGEN g;
71
72 new_oblist_length = MIN_OBLIST_LENGTH;
73 while ((new_oblist_length >> 1) < S_G.oblist_count)
74 new_oblist_length <<= 1;
75
76 if (new_oblist_length == S_G.oblist_length)
77 return;
78
79 new_oblist = S_getmem(new_oblist_length * sizeof(bucket *), 1, 0);
80
81 for (i = 0; i < S_G.oblist_length; i += 1) {
82 for (b = S_G.oblist[i]; b != NULL; b = bnext) {
83 int done = 0;
84 bnext = b->next;
85 sym = b->sym;
86 idx = OBINDEX(UNFIX(SYMHASH(sym)), new_oblist_length);
87 g = GENERATION(sym);
88
89 for (pb = &new_oblist[idx]; (oldb = *pb) != NULL && SegmentGeneration(addr_get_segment(TO_PTR(oldb))) < g; pb = &oldb->next) {
90 inc++;
91 if (done)
92 dinc++;
93 done = 1;
94 }
95 b->next = oldb;
96 *pb = b;
97 }
98 }
99
100 S_freemem(S_G.oblist, S_G.oblist_length * sizeof(bucket *));
101 S_G.bytesof[static_generation][countof_oblist] += (new_oblist_length - S_G.oblist_length) * sizeof(bucket *);
102
103 S_G.oblist_length = new_oblist_length;
104 S_G.oblist = new_oblist;
105 }
106
107 #define MIX_HASH(hc) (hc += (hc << 10), hc ^= (hc >> 6))
108
109 #define SYM_HASH_LOOP(uptr, iptr, extract, mask) { \
110 uptr h = (uptr)n + 401887359; \
111 while (n--) { h += extract(*s++); MIX_HASH(h); } \
112 return (iptr)h & mask; \
113 }
114
115 #define identity_extract(x) x
116
hash(const unsigned char * s,iptr n)117 static iptr hash(const unsigned char *s, iptr n) {
118 SYM_HASH_LOOP(uptr, iptr, identity_extract, most_positive_fixnum);
119 }
120
hash_sc(const string_char * s,iptr n)121 static iptr hash_sc(const string_char *s, iptr n) {
122 SYM_HASH_LOOP(uptr, iptr, Schar_value, most_positive_fixnum);
123 }
124
hash_uname(const string_char * s,iptr n)125 static iptr hash_uname(const string_char *s, iptr n) {
126 return hash_sc(s, n);
127 }
128
129 /* on any platform, computes the value that is computed on a 32-bit platform,
130 but needs to be `bitwise-and`ed with most_positive_fixnum */
S_symbol_hash32(ptr str)131 I32 S_symbol_hash32(ptr str) {
132 const string_char *s = &STRIT(str, 0); iptr n = Sstring_length(str);
133 SYM_HASH_LOOP(U32, I32, Schar_value, (I32)-1);
134 }
135
136 /* like S_symbol_hash32 for the value that is computed on a 64-bit platform */
S_symbol_hash64(ptr str)137 I64 S_symbol_hash64(ptr str) {
138 const string_char *s = &STRIT(str, 0); iptr n = Sstring_length(str);
139 SYM_HASH_LOOP(U64, I64, Schar_value, (U64)-1);
140 }
141
mkstring(const string_char * s,iptr n)142 static ptr mkstring(const string_char *s, iptr n) {
143 iptr i;
144 ptr str = S_string(NULL, n);
145 for (i = 0; i != n; i += 1) STRIT(str, i) = s[i];
146 STRTYPE(str) |= string_immutable_flag;
147 return str;
148 }
149
S_mkstring(const string_char * s,iptr n)150 ptr S_mkstring(const string_char *s, iptr n) {
151 return mkstring(s, n);
152 }
153
154 /* handles single-byte characters, implicit length */
S_intern(const unsigned char * s)155 ptr S_intern(const unsigned char *s) {
156 iptr n = strlen((const char *)s);
157 iptr hc = hash(s, n);
158 iptr idx = OBINDEX(hc, S_G.oblist_length);
159 ptr sym, str;
160 bucket *b;
161
162 tc_mutex_acquire();
163
164 b = S_G.oblist[idx];
165 while (b != NULL) {
166 sym = b->sym;
167 if (!GENSYMP(sym)) {
168 ptr str = SYMNAME(sym);
169 if (Sstring_length(str) == n) {
170 iptr i;
171 for (i = 0; ; i += 1) {
172 if (i == n) {
173 tc_mutex_release();
174 return sym;
175 }
176 if (Sstring_ref(str, i) != s[i]) break;
177 }
178 }
179 }
180 b = b->next;
181 }
182
183 str = S_string((const char *)s, n);
184 STRTYPE(str) |= string_immutable_flag;
185
186 sym = S_symbol(str);
187 INITSYMHASH(sym) = FIX(hc);
188 oblist_insert(sym, idx, 0);
189
190 tc_mutex_release();
191 return sym;
192 }
193
194 /* handles string_chars, explicit length */
S_intern_sc(const string_char * name,iptr n,ptr name_str)195 ptr S_intern_sc(const string_char *name, iptr n, ptr name_str) {
196 iptr hc = hash_sc(name, n);
197 iptr idx = OBINDEX(hc, S_G.oblist_length);
198 ptr sym;
199 bucket *b;
200
201 tc_mutex_acquire();
202
203 b = S_G.oblist[idx];
204 while (b != NULL) {
205 sym = b->sym;
206 if (!GENSYMP(sym)) {
207 ptr str = SYMNAME(sym);
208 if (Sstring_length(str) == n) {
209 iptr i;
210 for (i = 0; ; i += 1) {
211 if (i == n) {
212 tc_mutex_release();
213 return sym;
214 }
215 if (STRIT(str, i) != name[i]) break;
216 }
217 }
218 }
219 b = b->next;
220 }
221
222 if ((name_str == Sfalse) || !(STRTYPE(name_str) & string_immutable_flag))
223 name_str = mkstring(name, n);
224 sym = S_symbol(name_str);
225 INITSYMHASH(sym) = FIX(hc);
226 oblist_insert(sym, idx, 0);
227
228 tc_mutex_release();
229 return sym;
230 }
231
S_intern3(const string_char * pname,iptr plen,const string_char * uname,iptr ulen,ptr pname_str,ptr uname_str)232 ptr S_intern3(const string_char *pname, iptr plen, const string_char *uname, iptr ulen, ptr pname_str, ptr uname_str) {
233 iptr hc = hash_uname(uname, ulen);
234 iptr idx = OBINDEX(hc, S_G.oblist_length);
235 ptr sym;
236 bucket *b;
237
238 tc_mutex_acquire();
239
240 b = S_G.oblist[idx];
241 while (b != NULL) {
242 sym = b->sym;
243 if (GENSYMP(sym)) {
244 ptr str = Scar(SYMNAME(sym));
245 if (Sstring_length(str) == ulen) {
246 iptr i;
247 for (i = 0; ; i += 1) {
248 if (i == ulen) {
249 tc_mutex_release();
250 return sym;
251 }
252 if (STRIT(str, i) != uname[i]) break;
253 }
254 }
255 }
256 b = b->next;
257 }
258
259 if ((pname_str == Sfalse) || !(STRTYPE(pname_str) & string_immutable_flag))
260 pname_str = mkstring(pname, plen);
261 if ((uname_str == Sfalse) || !(STRTYPE(uname_str) & string_immutable_flag))
262 uname_str = mkstring(uname, ulen);
263 sym = S_symbol(Scons(uname_str, pname_str));
264 INITSYMHASH(sym) = FIX(hc);
265 oblist_insert(sym, idx, 0);
266
267 tc_mutex_release();
268 return sym;
269 }
270
S_intern_gensym(sym)271 void S_intern_gensym(sym) ptr sym; {
272 ptr uname_str = Scar(SYMNAME(sym));
273 const string_char *uname = &STRIT(uname_str, 0);
274 iptr ulen = Sstring_length(uname_str);
275 iptr hc = hash_uname(uname, ulen);
276 iptr idx = OBINDEX(hc, S_G.oblist_length);
277 bucket *b;
278
279 tc_mutex_acquire();
280
281 b = S_G.oblist[idx];
282 while (b != NULL) {
283 ptr x = b->sym;
284 if (GENSYMP(x)) {
285 ptr str = Scar(SYMNAME(x));
286 if (Sstring_length(str) == ulen) {
287 iptr i;
288 for (i = 0; ; i += 1) {
289 if (i == ulen) {
290 tc_mutex_release();
291 S_error1("intern-gensym", "unique name ~s already interned", uname_str);
292 }
293 if (STRIT(str, i) != uname[i]) break;
294 }
295 }
296 }
297 b = b->next;
298 }
299
300 INITSYMHASH(sym) = FIX(hc);
301 oblist_insert(sym, idx, GENERATION(sym));
302
303 tc_mutex_release();
304 }
305
306 /* must hold mutex */
S_intern4(sym)307 ptr S_intern4(sym) ptr sym; {
308 ptr name = SYMNAME(sym);
309 ptr uname_str = (Sstringp(name) ? name : Scar(name));
310 const string_char *uname = &STRIT(uname_str, 0);
311 iptr ulen = Sstring_length(uname_str);
312 iptr hc = UNFIX(SYMHASH(sym));
313 iptr idx = OBINDEX(hc, S_G.oblist_length);
314 bucket *b;
315
316 b = S_G.oblist[idx];
317 while (b != NULL) {
318 ptr x = b->sym;
319 ptr x_name = SYMNAME(x);
320 if (Sstringp(name) == Sstringp(x_name)) {
321 ptr str = (Sstringp(x_name) ? x_name : Scar(x_name));
322 if (Sstring_length(str) == ulen) {
323 iptr i;
324 for (i = 0; ; i += 1) {
325 if (i == ulen) {
326 return x;
327 }
328 if (STRIT(str, i) != uname[i]) break;
329 }
330 }
331 }
332 b = b->next;
333 }
334
335 oblist_insert(sym, idx, GENERATION(sym));
336
337 return sym;
338 }
339
340 /* retrofit existing symbols once nonprocedure_code is available */
S_retrofit_nonprocedure_code()341 void S_retrofit_nonprocedure_code() {
342 ptr npc, sym, val; bucket_list *bl;
343
344 npc = S_G.nonprocedure_code;
345
346 /* assuming this happens early, before collector has been called, so need look only for generation 0 symbols */
347 for (bl = S_G.buckets_of_generation[0]; bl != NULL; bl = bl->cdr) {
348 sym = bl->car->sym;
349 val = SYMVAL(sym);
350 SETSYMCODE(sym, Sprocedurep(val) ? CLOSCODE(val) : npc);
351 }
352 }
353