matita/components/ng_paramodulation/hash.c

   1 /***********************************************************************/
   2 /*                                                                     */
   3 /*                                OCaml                                */
   4 /*                                                                     */
   5 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
   6 /*                                                                     */
   7 /*  Copyright 1996 Institut National de Recherche en Informatique et   */
   8 /*  en Automatique.  All rights reserved.  This file is distributed    */
   9 /*  under the terms of the GNU Library General Public License, with    */
  10 /*  the special exception on linking described in file ../LICENSE.     */
  11 /*                                                                     */
  12 /***********************************************************************/
  13
  14 /* $Id: hash.c 12149 2012-02-10 16:15:24Z doligez $ */
  15
  16 /* The generic hashing primitive */
  17
  18 /* The interface of this file is in "mlvalues.h" (for [caml_hash_variant])
  19    and in "hash.h" (for the other exported functions). */
  20
  21 #include "mlvalues.h"
  22 #include "custom.h"
  23 #include "memory.h"
  24 #include "hash.h"
  25 #include "address_class.h"
  26
  27 /*#ifdef ARCH_INT64_TYPE
  28 #include "int64_native.h"
  29 #else
  30 #include "int64_emul.h"
  31 #endif*/
  32
  33 /* The old implementation */
  34
  35 static uintnat hash_accu;
  36 static intnat hash_univ_limit, hash_univ_count;
  37
  38 static void hash_aux(value obj);
  39
  40 CAMLprim value caml_hash_univ_param(value count, value limit, value obj)
  41 {
  42   hash_univ_limit = Long_val(limit);
  43   hash_univ_count = Long_val(count);
  44   hash_accu = 0;
  45   hash_aux(obj);
  46   return Val_long(hash_accu & 0x3FFFFFFF);
  47   /* The & has two purposes: ensure that the return value is positive
  48      and give the same result on 32 bit and 64 bit architectures. */
  49 }
  50
  51 #define Alpha 65599
  52 #define Beta 19
  53 #define Combine(new)  (hash_accu = hash_accu * Alpha + (new))
  54 #define Combine_small(new) (hash_accu = hash_accu * Beta + (new))
  55
  56 static void hash_aux(value obj)
  57 {
  58   unsigned char * p;
  59   mlsize_t i, j;
  60   tag_t tag;
  61
  62   hash_univ_limit--;
  63   if (hash_univ_count < 0 || hash_univ_limit < 0) return;
  64
  65  again:
  66   if (Is_long(obj)) {
  67     hash_univ_count--;
  68     Combine(Long_val(obj));
  69     return;
  70   }
  71
  72   /* Pointers into the heap are well-structured blocks. So are atoms.
  73      We can inspect the block contents. */
  74
  75   CAMLassert (Is_block (obj));
  76   if (Is_in_value_area(obj)) {
  77     tag = Tag_val(obj);
  78     switch (tag) {
  79     case String_tag:
  80       hash_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       hash_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       hash_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(obj - Infix_offset_val(obj));
 121       break;
 122     case Forward_tag:
 123       obj = Forward_val (obj);
 124       goto again;
 125     case Object_tag:
 126       hash_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         hash_univ_count--;
 133         Combine(Custom_ops_val(obj)->hash(obj));
 134       }
 135       break;
 136     default:
 137       hash_univ_count--;
 138       Combine_small(tag);
 139       i = Wosize_val(obj);
 140       while (i != 0) {
 141         i--;
 142         hash_aux(Field(obj, i));
 143       }
 144       break;
 145     }
 146     return;
 147   }
 148
 149   /* Otherwise, obj is a pointer outside the heap, to an object with
 150      a priori unknown structure. Use its physical address as hash key. */
 151   Combine((intnat) obj);
 152 }