feat: 9.5.9

c/intern.c

@@ -0,0 +1,389 @@
+/* intern.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include "system.h"
+
+/* locally defined functions */
+static void oblist_insert(ptr sym, iptr idx, IGEN g);
+static iptr hash(const unsigned char *s, iptr n);
+static iptr hash_sc(const string_char *s, iptr n);
+static iptr hash_uname(const string_char *s, iptr n);
+static ptr mkstring(const string_char *s, iptr n);
+
+/* list of some primes to use for oblist sizes */
+#if (ptr_bits == 32)
+static iptr oblist_lengths[] = {
+  1031,
+  2053,
+  4099,
+  8209,
+  16411,
+  32771,
+  65537,
+  131101,
+  262147,
+  524309,
+  1048583,
+  2097169,
+  4194319,
+  8388617,
+  16777259,
+  33554467,
+  67108879,
+  134217757,
+  268435459,
+  536870923,
+  1073741827,
+  0};
+#endif
+#if (ptr_bits == 64)
+static iptr oblist_lengths[] = {
+  1031,
+  2053,
+  4099,
+  8209,
+  16411,
+  32771,
+  65537,
+  131101,
+  262147,
+  524309,
+  1048583,
+  2097169,
+  4194319,
+  8388617,
+  16777259,
+  33554467,
+  67108879,
+  134217757,
+  268435459,
+  536870923,
+  1073741827,
+  2147483659,
+  4294967311,
+  8589934609,
+  17179869209,
+  34359738421,
+  68719476767,
+  137438953481,
+  274877906951,
+  549755813911,
+  1099511627791,
+  2199023255579,
+  4398046511119,
+  8796093022237,
+  17592186044423,
+  35184372088891,
+  70368744177679,
+  140737488355333,
+  281474976710677,
+  562949953421381,
+  1125899906842679,
+  2251799813685269,
+  4503599627370517,
+  9007199254740997,
+  18014398509482143,
+  36028797018963971,
+  72057594037928017,
+  144115188075855881,
+  288230376151711813,
+  576460752303423619,
+  1152921504606847009,
+  2305843009213693967,
+  4611686018427388039,
+  0};
+#endif
+
+void S_intern_init(void) {
+    IGEN g;
+
+    if (!S_boot_time) return;
+
+    S_G.oblist_length_pointer = &oblist_lengths[3];
+    S_G.oblist_length = *S_G.oblist_length_pointer;
+    S_G.oblist_count = 0;
+    S_G.oblist = S_getmem(S_G.oblist_length * sizeof(bucket *), 1);
+    for (g = 0; g < static_generation; g += 1) S_G.buckets_of_generation[g] = NULL;
+}
+
+static void oblist_insert(ptr sym, iptr idx, IGEN g) {
+  bucket *b, *oldb, **pb;
+
+  find_room(g == 0 ? space_new : space_data, g, typemod, sizeof(bucket), b);
+  b->sym = sym;
+  if (g == 0) {
+    b->next = S_G.oblist[idx];
+    S_G.oblist[idx] = b;
+  } else {
+    for (pb = &S_G.oblist[idx]; (oldb = *pb) != NULL && SegmentGeneration(addr_get_segment(oldb)) < g; pb = &oldb->next);
+    b->next = oldb;
+    *pb = b;
+  }
+
+  if (g != static_generation) {
+    bucket_list *bl;
+    find_room(g == 0 ? space_new : space_data, g, typemod, sizeof(bucket_list), bl);
+    bl->car = b;
+    bl->cdr = S_G.buckets_of_generation[g];
+    S_G.buckets_of_generation[g] = bl;
+  }
+
+  S_G.oblist_count += 1;
+}
+
+void S_resize_oblist(void) {
+  bucket **new_oblist, *b, *oldb, **pb, *bnext;
+  iptr *new_oblist_length_pointer, new_oblist_length, i, idx;
+  ptr sym;
+  IGEN g;
+
+  new_oblist_length_pointer = S_G.oblist_length_pointer;
+
+  if (S_G.oblist_count < S_G.oblist_length) {
+    while (new_oblist_length_pointer != &oblist_lengths[0] && *(new_oblist_length_pointer - 1) >= S_G.oblist_count) {
+      new_oblist_length_pointer -= 1;
+    }
+  } else if (S_G.oblist_count > S_G.oblist_length) {
+    while (*(new_oblist_length_pointer + 1) != 0 && *(new_oblist_length_pointer + 1) <= S_G.oblist_count) {
+      new_oblist_length_pointer += 1;
+    }
+  }
+
+  if (new_oblist_length_pointer == S_G.oblist_length_pointer) return;
+
+  new_oblist_length = *new_oblist_length_pointer;
+  new_oblist = S_getmem(new_oblist_length * sizeof(bucket *), 1);
+
+  for (i = 0; i < S_G.oblist_length; i += 1) {
+    for (b = S_G.oblist[i]; b != NULL; b = bnext) {
+      bnext = b->next;
+      sym = b->sym;
+      idx = UNFIX(SYMHASH(sym)) % new_oblist_length;
+      g = GENERATION(sym);
+
+      for (pb = &new_oblist[idx]; (oldb = *pb) != NULL && SegmentGeneration(addr_get_segment(oldb)) < g; pb = &oldb->next);
+      b->next = oldb;
+      *pb = b;
+    }
+  }
+
+  S_freemem(S_G.oblist, S_G.oblist_length * sizeof(bucket *));
+  S_G.bytesof[static_generation][countof_oblist] += (new_oblist_length - S_G.oblist_length) * sizeof(bucket *);
+
+  S_G.oblist_length_pointer = new_oblist_length_pointer;
+  S_G.oblist_length = new_oblist_length;
+  S_G.oblist = new_oblist;
+}
+
+/* hash function: multiplier weights each character, h = n factors in the length */
+#define multiplier 3
+
+static iptr hash(const unsigned char *s, iptr n) {
+  iptr h = n + 401887359;
+  while (n--) h = h * multiplier + *s++;
+  return h & most_positive_fixnum;
+}
+
+static iptr hash_sc(const string_char *s, iptr n) {
+  iptr h = n + 401887359;
+  while (n--) h = h * multiplier + Schar_value(*s++);
+  return h & most_positive_fixnum;
+}
+
+static iptr hash_uname(const string_char *s, iptr n) {
+  /* attempting to get dissimilar hash codes for gensyms created in the same session */
+  iptr i = n, h = 0; iptr pos = 1; int d, c;
+
+  while (i-- > 0) {
+    if ((c = Schar_value(s[i])) == '-') {
+      if (pos <= 10) break;
+      return (h + 523658599) & most_positive_fixnum;
+    }
+    d = c - '0';
+    if (d < 0 || d > 9) break;
+    h += d * pos;
+    pos *= 10;
+  }
+
+  return hash_sc(s, n);
+}
+
+static ptr mkstring(const string_char *s, iptr n) {
+  iptr i;
+  ptr str = S_string(NULL, n);
+  for (i = 0; i != n; i += 1) STRIT(str, i) = s[i];
+  return str;
+}
+
+/* handles single-byte characters, implicit length */
+ptr S_intern(const unsigned char *s) {
+  iptr n = strlen((const char *)s);
+  iptr hc = hash(s, n);
+  iptr idx = hc % S_G.oblist_length;
+  ptr sym;
+  bucket *b;
+
+  tc_mutex_acquire()
+
+  b = S_G.oblist[idx];
+  while (b != NULL) {
+    sym = b->sym;
+    if (!GENSYMP(sym)) {
+       ptr str = SYMNAME(sym);
+       if (Sstring_length(str) == n) {
+          iptr i;
+          for (i = 0; ; i += 1) {
+            if (i == n) {
+               tc_mutex_release()
+               return sym;
+            }
+            if (Sstring_ref(str, i) != s[i]) break;
+          }
+       }
+    }
+    b = b->next;
+  }
+
+  sym = S_symbol(S_string((const char *)s, n));
+  INITSYMHASH(sym) = FIX(hc);
+  oblist_insert(sym, idx, 0);
+
+  tc_mutex_release()
+  return sym;
+}
+
+/* handles string_chars, explicit length */
+ptr S_intern_sc(const string_char *name, iptr n, ptr name_str) {
+  iptr hc = hash_sc(name, n);
+  iptr idx = hc % S_G.oblist_length;
+  ptr sym;
+  bucket *b;
+
+  tc_mutex_acquire()
+
+  b = S_G.oblist[idx];
+  while (b != NULL) {
+    sym = b->sym;
+    if (!GENSYMP(sym)) {
+       ptr str = SYMNAME(sym);
+       if (Sstring_length(str) == n) {
+          iptr i;
+          for (i = 0; ; i += 1) {
+            if (i == n) {
+               tc_mutex_release()
+               return sym;
+            }
+            if (STRIT(str, i) != name[i]) break;
+          }
+       }
+    }
+    b = b->next;
+  }
+
+  /* if (name_str == Sfalse) */ name_str = mkstring(name, n);
+  sym = S_symbol(name_str);
+  INITSYMHASH(sym) = FIX(hc);
+  oblist_insert(sym, idx, 0);
+
+  tc_mutex_release()
+  return sym;
+}
+
+ptr S_intern3(const string_char *pname, iptr plen, const string_char *uname, iptr ulen, ptr pname_str, ptr uname_str) {
+  iptr hc = hash_uname(uname, ulen);
+  iptr idx = hc % S_G.oblist_length;
+  ptr sym;
+  bucket *b;
+
+  tc_mutex_acquire()
+
+  b = S_G.oblist[idx];
+  while (b != NULL) {
+    sym = b->sym;
+    if (GENSYMP(sym)) {
+       ptr str = Scar(SYMNAME(sym));
+       if (Sstring_length(str) == ulen) {
+          iptr i;
+          for (i = 0; ; i += 1) {
+            if (i == ulen) {
+               tc_mutex_release()
+               return sym;
+            }
+            if (STRIT(str, i) != uname[i]) break;
+          }
+       }
+    }
+    b = b->next;
+  }
+
+  if (pname_str == Sfalse) pname_str = mkstring(pname, plen);
+  if (uname_str == Sfalse) uname_str = mkstring(uname, ulen);
+  sym = S_symbol(Scons(uname_str, pname_str));
+  INITSYMHASH(sym) = FIX(hc);
+  oblist_insert(sym, idx, 0);
+
+  tc_mutex_release()
+  return sym;
+}
+
+void S_intern_gensym(ptr sym) {
+  ptr uname_str = Scar(SYMNAME(sym));
+  const string_char *uname = &STRIT(uname_str, 0);
+  iptr ulen = Sstring_length(uname_str);
+  iptr hc = hash_uname(uname, ulen);
+  iptr idx = hc % S_G.oblist_length;
+  bucket *b;
+
+  tc_mutex_acquire()
+
+  b = S_G.oblist[idx];
+  while (b != NULL) {
+    ptr x = b->sym;
+    if (GENSYMP(x)) {
+       ptr str = Scar(SYMNAME(x));
+       if (Sstring_length(str) == ulen) {
+          iptr i;
+          for (i = 0; ; i += 1) {
+            if (i == ulen) {
+               tc_mutex_release()
+               S_error1("intern-gensym", "unique name ~s already interned", uname_str);
+            }
+            if (Sstring_ref(str, i) != uname[i]) break;
+          }
+       }
+    }
+    b = b->next;
+  }
+
+  INITSYMHASH(sym) = FIX(hc);
+  oblist_insert(sym, idx, GENERATION(sym));
+
+  tc_mutex_release()
+}
+
+/* retrofit existing symbols once nonprocedure_code is available */
+void S_retrofit_nonprocedure_code(void) {
+  ptr npc, sym, val; bucket_list *bl;
+
+  npc = S_G.nonprocedure_code;
+
+  /* assuming this happens early, before collector has been called, so need look only for generation 0 symbols */
+  for (bl = S_G.buckets_of_generation[0]; bl != NULL; bl = bl->cdr) {
+    sym = bl->car->sym;
+    val = SYMVAL(sym);
+    SETSYMCODE(sym, Sprocedurep(val) ? CLOSCODE(val) : npc);
+  }
+}