diff src/elhash.c @ 5118:e0db3c197671 ben-lisp-object

merge up to latest default branch, doesn't compile yet
author Ben Wing <ben@xemacs.org>
date Sat, 26 Dec 2009 21:18:49 -0600
parents 3742ea8250b5 fd98353950a4
children d1247f3cc363
line wrap: on
line diff
--- a/src/elhash.c	Sat Dec 26 00:20:27 2009 -0600
+++ b/src/elhash.c	Sat Dec 26 21:18:49 2009 -0600
@@ -94,12 +94,6 @@
 static Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qkey_or_value_weak;
 static Lisp_Object Qnon_weak, Q_type;
 
-typedef struct htentry
-{
-  Lisp_Object key;
-  Lisp_Object value;
-} htentry;
-
 struct Lisp_Hash_Table
 {
   struct LCRECORD_HEADER header;
@@ -117,7 +111,6 @@
 			        hash tables.  Don't mark through this. */
 };
 
-#define HTENTRY_CLEAR_P(htentry) ((*(EMACS_UINT*)(&((htentry)->key))) == 0)
 #define CLEAR_HTENTRY(htentry)   \
   ((*(EMACS_UINT*)(&((htentry)->key)))   = 0, \
    (*(EMACS_UINT*)(&((htentry)->value))) = 0)
@@ -125,6 +118,8 @@
 #define HASH_TABLE_DEFAULT_SIZE 16
 #define HASH_TABLE_DEFAULT_REHASH_SIZE 1.3
 #define HASH_TABLE_MIN_SIZE 10
+#define HASH_TABLE_DEFAULT_REHASH_THRESHOLD(size, test_function)   \
+  (((size) > 4096 && NULL == (test_function)) ? 0.7 : 0.6)
 
 #define HASHCODE(key, ht)						\
   ((((ht)->hash_function ? (ht)->hash_function (key) : LISP_HASH (key))	\
@@ -360,6 +355,7 @@
 		  int UNUSED (escapeflag))
 {
   Lisp_Hash_Table *ht = XHASH_TABLE (obj);
+  Ascbyte pigbuf[350];
 
   write_c_string (printcharfun,
 		  print_readably ? "#s(hash-table" : "#<hash-table");
@@ -396,6 +392,20 @@
 	  "you-d-better-not-see-this"));
     }
 
+  if (ht->rehash_size != HASH_TABLE_DEFAULT_REHASH_SIZE)
+    {
+      float_to_string (pigbuf, ht->rehash_size);
+      write_fmt_string (printcharfun, " rehash-size %s", pigbuf);
+    }
+
+  if (ht->rehash_threshold
+      != HASH_TABLE_DEFAULT_REHASH_THRESHOLD (ht->size,
+					      ht->test_function))
+    {
+      float_to_string (pigbuf, ht->rehash_threshold);
+      write_fmt_string (printcharfun, " rehash-threshold %s", pigbuf);
+    }
+
   if (ht->count)
     print_hash_table_data (ht, printcharfun);
 
@@ -405,13 +415,14 @@
     write_fmt_string (printcharfun, " 0x%x>", ht->header.uid);
 }
 
+#ifndef NEW_GC
 static void
 free_hentries (htentry *hentries,
 #ifdef ERROR_CHECK_STRUCTURES
 	       size_t size
-#else
+#else /* not ERROR_CHECK_STRUCTURES) */
 	       size_t UNUSED (size)
-#endif
+#endif /* not ERROR_CHECK_STRUCTURES) */
 	       )
 {
 #ifdef ERROR_CHECK_STRUCTURES
@@ -436,6 +447,7 @@
       ht->hentries = 0;
     }
 }
+#endif /* not NEW_GC */
 
 static const struct memory_description htentry_description_1[] = {
   { XD_LISP_OBJECT, offsetof (htentry, key) },
@@ -448,13 +460,37 @@
   htentry_description_1
 };
 
+#ifdef NEW_GC
+static const struct memory_description htentry_weak_description_1[] = {
+  { XD_LISP_OBJECT, offsetof (htentry, key), 0, { 0 }, XD_FLAG_NO_KKCC},
+  { XD_LISP_OBJECT, offsetof (htentry, value), 0, { 0 }, XD_FLAG_NO_KKCC},
+  { XD_END }
+};
+
+static const struct sized_memory_description htentry_weak_description = {
+  sizeof (htentry),
+  htentry_weak_description_1
+};
+
+DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("hash-table-entry", hash_table_entry,
+				      0, htentry_description_1,
+				      Lisp_Hash_Table_Entry);
+#endif /* NEW_GC */
+
 static const struct memory_description htentry_union_description_1[] = {
   /* Note: XD_INDIRECT in this table refers to the surrounding table,
      and so this will work. */
+#ifdef NEW_GC
+  { XD_LISP_OBJECT_BLOCK_PTR, HASH_TABLE_NON_WEAK,
+    XD_INDIRECT (0, 1), { &htentry_description } },
+  { XD_LISP_OBJECT_BLOCK_PTR, 0, XD_INDIRECT (0, 1),
+    { &htentry_weak_description }, XD_FLAG_UNION_DEFAULT_ENTRY },
+#else /* not NEW_GC */
   { XD_BLOCK_PTR, HASH_TABLE_NON_WEAK, XD_INDIRECT (0, 1),
     { &htentry_description } },
   { XD_BLOCK_PTR, 0, XD_INDIRECT (0, 1), { &htentry_description },
     XD_FLAG_UNION_DEFAULT_ENTRY | XD_FLAG_NO_KKCC },
+#endif /* not NEW_GC */
   { XD_END }
 };
 
@@ -472,12 +508,20 @@
   { XD_END }
 };
 
-DEFINE_LISP_OBJECT ("hash-table", hash_table,
-			       mark_hash_table, print_hash_table,
-			       finalize_hash_table,
-			       hash_table_equal, hash_table_hash,
-			       hash_table_description,
-			       Lisp_Hash_Table);
+#ifdef NEW_GC
+DEFINE_DUMPABLE_LISP_OBJECT ("hash-table", hash_table,
+			     mark_hash_table, print_hash_table,
+			     0, hash_table_equal, hash_table_hash,
+			     hash_table_description,
+			     Lisp_Hash_Table);
+#else /* not NEW_GC */
+DEFINE_DUMPABLE_LISP_OBJECT ("hash-table", hash_table,
+			     mark_hash_table, print_hash_table,
+			     finalize_hash_table,
+			     hash_table_equal, hash_table_hash,
+			     hash_table_description,
+			     Lisp_Hash_Table);
+#endif /* not NEW_GC */
 
 static Lisp_Hash_Table *
 xhash_table (Lisp_Object hash_table)
@@ -504,6 +548,17 @@
     ((double) ht->size * (.6180339887 / (double) sizeof (Lisp_Object)));
 }
 
+static htentry *
+allocate_hash_table_entries (Elemcount size)
+{
+#ifdef NEW_GC
+  return XHASH_TABLE_ENTRY (alloc_lrecord_array
+			    (size, &lrecord_hash_table_entry));
+#else /* not NEW_GC */
+  return xnew_array_and_zero (htentry, size);
+#endif /* not NEW_GC */
+}
+
 Lisp_Object
 make_standard_lisp_hash_table (enum hash_table_test test,
 			       Elemcount size,
@@ -560,7 +615,7 @@
 
   ht->rehash_threshold =
     rehash_threshold > 0.0 ? rehash_threshold :
-    size > 4096 && !ht->test_function ? 0.7 : 0.6;
+    HASH_TABLE_DEFAULT_REHASH_THRESHOLD (size, ht->test_function);
 
   if (size < HASH_TABLE_MIN_SIZE)
     size = HASH_TABLE_MIN_SIZE;
@@ -571,7 +626,7 @@
   compute_hash_table_derived_values (ht);
 
   /* We leave room for one never-occupied sentinel htentry at the end.  */
-  ht->hentries = xnew_array_and_zero (htentry, ht->size + 1);
+  ht->hentries = allocate_hash_table_entries (ht->size + 1);
 
   if (weakness == HASH_TABLE_NON_WEAK)
     ht->next_weak = Qunbound;
@@ -716,6 +771,7 @@
 static double
 decode_hash_table_rehash_size (Lisp_Object rehash_size)
 {
+  /* -1.0 signals make_general_lisp_hash_table to use the default. */
   return NILP (rehash_size) ? -1.0 : XFLOAT_DATA (rehash_size);
 }
 
@@ -747,6 +803,7 @@
 static double
 decode_hash_table_rehash_threshold (Lisp_Object rehash_threshold)
 {
+  /* -1.0 signals make_general_lisp_hash_table to use the default. */
   return NILP (rehash_threshold) ? -1.0 : XFLOAT_DATA (rehash_threshold);
 }
 
@@ -756,6 +813,7 @@
 {
   int len;
 
+  /* Check for improper lists while getting length. */
   GET_EXTERNAL_LIST_LENGTH (value, len);
 
   if (len & 1)
@@ -765,6 +823,7 @@
 	 value, Qhash_table, errb);
       return 0;
     }
+  
   return 1;
 }
 
@@ -869,7 +928,6 @@
 DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /*
 Return a new empty hash table object.
 Use Common Lisp style keywords to specify hash table properties.
- (make-hash-table &key test size rehash-size rehash-threshold weakness)
 
 Keyword :test can be `eq', `eql' (default) or `equal'.
 Comparison between keys is done using this function.
@@ -913,6 +971,8 @@
 unmarked outside of weak hash tables.  The pair will remain in the
 hash table if the value or key are pointed to by something other than a weak
 hash table, even if the other is not.
+
+arguments: (&key TEST SIZE REHASH-SIZE REHASH-THRESHOLD WEAKNESS)
 */
        (int nargs, Lisp_Object *args))
 {
@@ -968,7 +1028,8 @@
   Lisp_Hash_Table *ht = XHASH_TABLE (obj);
   COPY_LCRECORD (ht, ht_old);
 
-  ht->hentries = xnew_array (htentry, ht_old->size + 1);
+  /* We leave room for one never-occupied sentinel htentry at the end.  */
+  ht->hentries = allocate_hash_table_entries (ht_old->size + 1);
   memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (htentry));
 
   if (! EQ (ht->next_weak, Qunbound))
@@ -991,7 +1052,8 @@
 
   old_entries = ht->hentries;
 
-  ht->hentries = xnew_array_and_zero (htentry, new_size + 1);
+  /* We leave room for one never-occupied sentinel htentry at the end.  */
+  ht->hentries = allocate_hash_table_entries (new_size + 1);
   new_entries = ht->hentries;
 
   compute_hash_table_derived_values (ht);
@@ -1005,7 +1067,9 @@
 	*probe = *e;
       }
 
+#ifndef NEW_GC
   free_hentries (old_entries, old_size);
+#endif /* not NEW_GC */
 }
 
 /* After a hash table has been saved to disk and later restored by the
@@ -1015,7 +1079,8 @@
 pdump_reorganize_hash_table (Lisp_Object hash_table)
 {
   const Lisp_Hash_Table *ht = xhash_table (hash_table);
-  htentry *new_entries = xnew_array_and_zero (htentry, ht->size + 1);
+  /* We leave room for one never-occupied sentinel htentry at the end.  */
+  htentry *new_entries = allocate_hash_table_entries (ht->size + 1);
   htentry *e, *sentinel;
 
   for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
@@ -1029,7 +1094,9 @@
 
   memcpy (ht->hentries, new_entries, ht->size * sizeof (htentry));
 
+#ifndef NEW_GC
   xfree (new_entries, htentry *);
+#endif /* not NEW_GC */
 }
 
 static void
@@ -1040,7 +1107,7 @@
   resize_hash_table (ht, new_size);
 }
 
-static htentry *
+htentry *
 find_htentry (Lisp_Object key, const Lisp_Hash_Table *ht)
 {
   hash_table_test_function_t test_function = ht->test_function;
@@ -1096,7 +1163,7 @@
 }
 
 DEFUN ("puthash", Fputhash, 3, 3, 0, /*
-Hash KEY to VALUE in HASH-TABLE.
+Hash KEY to VALUE in HASH-TABLE, and return VALUE. 
 */
        (key, value, hash_table))
 {
@@ -1160,6 +1227,7 @@
 
 DEFUN ("clrhash", Fclrhash, 1, 1, 0, /*
 Remove all entries from HASH-TABLE, leaving it empty.
+Return HASH-TABLE.
 */
        (hash_table))
 {
@@ -1657,12 +1725,33 @@
 {
   if (depth > 5)
     return 0;
-  if (CONSP (obj))
+
+  if (CONSP(obj)) 
     {
-      /* no point in worrying about tail recursion, since we're not
-	 going very deep */
-      return HASH2 (internal_hash (XCAR (obj), depth + 1),
-		    internal_hash (XCDR (obj), depth + 1));
+      Hashcode hash, h;
+      int s;
+
+      depth += 1;
+
+      if (!CONSP(XCDR(obj)))
+	{
+	  /* special case for '(a . b) conses */
+	  return HASH2(internal_hash(XCAR(obj), depth),
+		       internal_hash(XCDR(obj), depth));
+	}
+
+      /* Don't simply tail recurse; we want to hash lists with the
+	 same contents in distinct orders differently. */
+      hash = internal_hash(XCAR(obj), depth);
+
+      obj = XCDR(obj);
+      for (s = 1; s < 6 && CONSP(obj); obj = XCDR(obj), s++)
+	{
+	  h = internal_hash(XCAR(obj), depth);
+	  hash = HASH3(hash, h, s);
+	}
+
+      return hash;
     }
   if (STRINGP (obj))
     {
@@ -1757,6 +1846,9 @@
 init_elhash_once_early (void)
 {
   INIT_LISP_OBJECT (hash_table);
+#ifdef NEW_GC
+  INIT_LISP_OBJECT (hash_table_entry);
+#endif /* NEW_GC */
 
   /* This must NOT be staticpro'd */
   Vall_weak_hash_tables = Qnil;