hash_compat.c (5365B)
1 /* The pre-OCaml 4.00 hash implementation */ 2 /* FIXME: This is included for backwards compatibility only and must be 3 * REMOVED when a new hash function included in a stable release has been 4 * available for a few years. The removal of this function will break 5 * Unison version compatibility. There must be plenty of time given 6 * for users to upgrade (most users don't compile themselves and are at 7 * mercy of whatever package repositories they use). */ 8 9 /* Code copied from OCaml sources */ 10 /**************************************************************************/ 11 /* */ 12 /* OCaml */ 13 /* */ 14 /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ 15 /* */ 16 /* Copyright 1996 Institut National de Recherche en Informatique et */ 17 /* en Automatique. */ 18 /* */ 19 /* All rights reserved. This file is distributed under the terms of */ 20 /* the GNU Lesser General Public License version 2.1, with the */ 21 /* special exception on linking described in the file LICENSE. */ 22 /* */ 23 /**************************************************************************/ 24 25 #include <caml/mlvalues.h> 26 #include <caml/custom.h> 27 #include <caml/address_class.h> 28 29 struct hash_state { 30 uintnat accu; 31 intnat univ_limit, univ_count; 32 }; 33 34 static void hash_aux(struct hash_state*, value obj); 35 36 CAMLprim value unsn_hash_univ_param(value count, value limit, value obj) 37 { 38 struct hash_state h; 39 h.univ_limit = Long_val(limit); 40 h.univ_count = Long_val(count); 41 h.accu = 0; 42 hash_aux(&h, obj); 43 return Val_long(h.accu & 0x3FFFFFFF); 44 /* The & has two purposes: ensure that the return value is positive 45 and give the same result on 32 bit and 64 bit architectures. */ 46 } 47 48 #define Alpha 65599 49 #define Beta 19 50 #define Combine(new) (h->accu = h->accu * Alpha + (new)) 51 #define Combine_small(new) (h->accu = h->accu * Beta + (new)) 52 53 static void hash_aux(struct hash_state* h, value obj) 54 { 55 unsigned char * p; 56 mlsize_t i, j; 57 tag_t tag; 58 59 h->univ_limit--; 60 if (h->univ_count < 0 || h->univ_limit < 0) return; 61 62 again: 63 if (Is_long(obj)) { 64 h->univ_count--; 65 Combine(Long_val(obj)); 66 return; 67 } 68 if (! Is_in_value_area(obj)) { 69 /* obj is a pointer outside the heap, to an object with 70 a priori unknown structure. Use its physical address as hash key. */ 71 Combine((intnat) obj); 72 return; 73 } 74 /* Pointers into the heap are well-structured blocks. So are atoms. 75 We can inspect the block contents. */ 76 /* The code needs reindenting later. Leaving as is to facilitate review. */ 77 tag = Tag_val(obj); 78 switch (tag) { 79 case String_tag: 80 h->univ_count--; 81 i = caml_string_length(obj); 82 for (p = &Byte_u(obj, 0); i > 0; i--, p++) 83 Combine_small(*p); 84 break; 85 case Double_tag: 86 /* For doubles, we inspect their binary representation, LSB first. 87 The results are consistent among all platforms with IEEE floats. */ 88 h->univ_count--; 89 #ifdef ARCH_BIG_ENDIAN 90 for (p = &Byte_u(obj, sizeof(double) - 1), i = sizeof(double); 91 i > 0; 92 p--, i--) 93 #else 94 for (p = &Byte_u(obj, 0), i = sizeof(double); 95 i > 0; 96 p++, i--) 97 #endif 98 Combine_small(*p); 99 break; 100 case Double_array_tag: 101 h->univ_count--; 102 for (j = 0; j < Bosize_val(obj); j += sizeof(double)) { 103 #ifdef ARCH_BIG_ENDIAN 104 for (p = &Byte_u(obj, j + sizeof(double) - 1), i = sizeof(double); 105 i > 0; 106 p--, i--) 107 #else 108 for (p = &Byte_u(obj, j), i = sizeof(double); 109 i > 0; 110 p++, i--) 111 #endif 112 Combine_small(*p); 113 } 114 break; 115 case Abstract_tag: 116 /* We don't know anything about the contents of the block. 117 Better do nothing. */ 118 break; 119 case Infix_tag: 120 hash_aux(h, obj - Infix_offset_val(obj)); 121 break; 122 case Forward_tag: 123 obj = Forward_val (obj); 124 goto again; 125 case Object_tag: 126 h->univ_count--; 127 Combine(Oid_val(obj)); 128 break; 129 case Custom_tag: 130 /* If no hashing function provided, do nothing */ 131 if (Custom_ops_val(obj)->hash != NULL) { 132 h->univ_count--; 133 Combine(Custom_ops_val(obj)->hash(obj)); 134 } 135 break; 136 #ifdef NO_NAKED_POINTERS 137 case Closure_tag: 138 h->univ_count--; 139 Combine_small(tag); 140 /* Recursively hash the environment fields */ 141 i = Wosize_val(obj); 142 j = Start_env_closinfo(Closinfo_val(obj)); 143 while (i > j) { 144 i--; 145 hash_aux(h, Field(obj, i)); 146 } 147 /* Combine the code pointers, closure info fields, and infix headers */ 148 while (i > 0) { 149 i--; 150 Combine(Field(obj, i)); 151 h->univ_count--; 152 } 153 break; 154 #endif 155 default: 156 h->univ_count--; 157 Combine_small(tag); 158 i = Wosize_val(obj); 159 while (i != 0) { 160 i--; 161 hash_aux(h, Field(obj, i)); 162 } 163 break; 164 } 165 }