xemacs-beta: src/elhash.c comparison

comparison 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

comparison

equal deleted inserted replaced

-:3742ea8250b5
+:e0db3c197671
 static Lisp_Object Q_size, Q_test, Q_weakness, Q_rehash_size, Q_rehash_threshold;
 /* obsolete as of 19990901 in xemacs-21.2 */
 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;
 Elemcount size;
 enum hash_table_weakness weakness;
 Lisp_Object next_weak;     /* Used to chain together all of the weak
 			        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)
 #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))	\
 * (ht)->golden_ratio)						\
 % (ht)->size)
 static void
 print_hash_table (Lisp_Object obj, Lisp_Object printcharfun,
 		  int UNUSED (escapeflag))
 {
 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
+Ascbyte pigbuf[350];
 write_c_string (printcharfun,
 		  print_readably ? "#s(hash-table" : "#<hash-table");
 /* These checks have a kludgy look to them, but they are safe.
 	  ht->weakness == HASH_TABLE_VALUE_WEAK	    ? "value" :
 	  ht->weakness == HASH_TABLE_KEY_VALUE_WEAK ? "key-or-value" :
 	  "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);
 if (print_readably)
 write_c_string (printcharfun, ")");
 else
 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
 /* Ensure a crash if other code uses the discarded entries afterwards. */
 htentry *e, *sentinel;
 Lisp_Hash_Table *ht = (Lisp_Hash_Table *) header;
 free_hentries (ht->hentries, ht->size);
 ht->hentries = 0;
 }
 }
+#endif /* not NEW_GC */
 static const struct memory_description htentry_description_1[] = {
 { XD_LISP_OBJECT, offsetof (htentry, key) },
 { XD_LISP_OBJECT, offsetof (htentry, value) },
 { XD_END }
 static const struct sized_memory_description htentry_description = {
 sizeof (htentry),
 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 }
 };
 static const struct sized_memory_description htentry_union_description = {
 sizeof (htentry *),
 { &htentry_union_description } },
 { XD_LO_LINK,    offsetof (Lisp_Hash_Table, next_weak) },
 { XD_END }
 };
-DEFINE_LISP_OBJECT ("hash-table", hash_table,
+#ifdef NEW_GC
-			       mark_hash_table, print_hash_table,
+DEFINE_DUMPABLE_LISP_OBJECT ("hash-table", hash_table,
-			       finalize_hash_table,
+			     mark_hash_table, print_hash_table,
-			       hash_table_equal, hash_table_hash,
+			     0, hash_table_equal, hash_table_hash,
-			       hash_table_description,
+			     hash_table_description,
-			       Lisp_Hash_Table);
+			     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)
 {
 /* #### What's going on here?  Why the gc_in_progress check? */
 {
 ht->rehash_count = (Elemcount)
 ((double) ht->size * ht->rehash_threshold);
 ht->golden_ratio = (Elemcount)
 ((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,
 ht->rehash_size =
 rehash_size > 1.0 ? rehash_size : HASH_TABLE_DEFAULT_REHASH_SIZE;
 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;
 ht->size = hash_table_size ((Elemcount) (((double) size / ht->rehash_threshold)
 					+ 1.0));
 ht->count = 0;
 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;
 else
 ht->next_weak = Vall_weak_hash_tables, Vall_weak_hash_tables = hash_table;
 }
 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);
 }
 static int
 hash_table_rehash_threshold_validate (Lisp_Object UNUSED (keyword),
 }
 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);
 }
 static int
 hash_table_data_validate (Lisp_Object UNUSED (keyword), Lisp_Object value,
 			  Error_Behavior errb)
 {
 int len;
+/* Check for improper lists while getting length. */
 GET_EXTERNAL_LIST_LENGTH (value, len);
 if (len & 1)
 {
 maybe_sferror
 	("Hash table data must have alternating key/value pairs",
 	 value, Qhash_table, errb);
 return 0;
 }
 return 1;
 }
 /* The actual instantiation of a hash table.  This does practically no
 error checking, because it relies on the fact that the paranoid
 }
 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.
 If speed is important, consider using `eq'.
 When storing strings in the hash table, you will likely need to use `equal'.
 A key-or-value-weak hash table is similar to a fully-weak hash table except
 that a key-value pair will be removed only if the value and the key remain
 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))
 {
 int i = 0;
 Lisp_Object test	       = Qnil;
 const Lisp_Hash_Table *ht_old = xhash_table (hash_table);
 Lisp_Object obj = ALLOC_LISP_OBJECT (hash_table);
 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))
 {
 ht->next_weak = Vall_weak_hash_tables;
 old_size = ht->size;
 ht->size = new_size;
 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);
 for (e = old_entries, sentinel = e + old_size; e < sentinel; e++)
 	LINEAR_PROBING_LOOP (probe, new_entries, new_size)
 	  ;
 	*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
 portable dumper, it contains the same objects, but their addresses
 and thus their HASHCODEs have changed. */
 void
 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++)
 if (!HTENTRY_CLEAR_P (e))
 {
 	*probe = *e;
 }
 memcpy (ht->hentries, new_entries, ht->size * sizeof (htentry));
+#ifndef NEW_GC
 xfree (new_entries, htentry *);
+#endif /* not NEW_GC */
 }
 static void
 enlarge_hash_table (Lisp_Hash_Table *ht)
 {
 Elemcount new_size =
 hash_table_size ((Elemcount) ((double) ht->size * ht->rehash_size));
 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;
 htentry *entries = ht->hentries;
 htentry *probe = entries + HASHCODE (key, ht);
 return HTENTRY_CLEAR_P (e) ? default_ : e->value;
 }
 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))
 {
 Lisp_Hash_Table *ht = xhash_table (hash_table);
 htentry *e = find_htentry (key, ht);
 return Qt;
 }
 DEFUN ("clrhash", Fclrhash, 1, 1, 0, /*
 Remove all entries from HASH-TABLE, leaving it empty.
+Return HASH-TABLE.
 */
 (hash_table))
 {
 Lisp_Hash_Table *ht = xhash_table (hash_table);
 htentry *e, *sentinel;
 Hashcode
 internal_hash (Lisp_Object obj, int depth)
 {
 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 */
+Hashcode hash, h;
-return HASH2 (internal_hash (XCAR (obj), depth + 1),
+int s;
-		    internal_hash (XCDR (obj), depth + 1));
+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))
 {
 return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj));
 }
 void
 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;
 dump_add_weak_object_chain (&Vall_weak_hash_tables);
 }

Mercurial > hg > xemacs-beta

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