src/hcons.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                               TAToo                                 *)
   4 (*                                                                     *)
   5 (*                     Kim Nguyen, LRI UMR8623                         *)
   6 (*                   Université Paris-Sud & CNRS                       *)
   7 (*                                                                     *)
   8 (*  Copyright 2010-2012 Université Paris-Sud and Centre National de la *)
   9 (*  Recherche Scientifique. All rights reserved.  This file is         *)
  10 (*  distributed under the terms of the GNU Lesser General Public       *)
  11 (*  License, with the special exception on linking described in file   *)
  12 (*  ../LICENSE.                                                        *)
  13 (*                                                                     *)
  14 (***********************************************************************)
  15
  16 module type Abstract =
  17   sig
  18     type data
  19     type t
  20     val make : data -> t
  21     val node : t -> data
  22     val hash : t -> int
  23     val uid : t -> Uid.t
  24     val equal : t -> t -> bool
  25     val init : unit -> unit
  26   end
  27
  28 type 'a node = { id   : Uid.t;
  29                  key  : int;
  30                  node : 'a }
  31 module type S =
  32 sig
  33   type data
  34   type t = private { id   : Uid.t;
  35                      key  : int;
  36                      node : data }
  37   include Abstract with type data := data and type t := t
  38 end
  39
  40 module type TableBuilder =
  41   functor
  42     (H : Sigs.HashedType) ->
  43       Sigs.HashSet with type data = H.t
  44
  45 module Builder (TB : TableBuilder) (H : Sigs.HashedType) =
  46 struct
  47   type data = H.t
  48   type t = { id   : Uid.t;
  49              key  : int;
  50              node : data }
  51   let uid_make = ref (Uid.make_maker())
  52   let node t = t.node
  53   let uid t = t.id
  54   let hash t = t.key
  55   let equal t1 t2 = t1 == t2
  56   module HN =
  57   struct
  58     type _t = t
  59     type t = _t
  60     let hash = hash
  61     let equal x y = x == y || H.equal x.node y.node
  62   end
  63   module T = TB(HN)
  64
  65   let pool = T.create 101
  66   let init () =
  67     T.clear pool;
  68     uid_make := Uid.make_maker ()
  69
  70   let make x =
  71     let cell = { id = Uid.dummy; key = H.hash x; node = x } in
  72     try
  73       T.find pool cell
  74     with
  75     | Not_found ->
  76       let cell = { cell with id = !uid_make(); } in
  77       T.add pool cell;
  78       cell
  79 end
  80
  81 module Make = Builder (Utils.HashSet)
  82 module Weak = Builder (Weak.Make)
  83
  84 module PosInt =
  85 struct
  86   type data = int
  87   type t = int
  88   let make v =
  89     if v < 0 then raise (Invalid_argument "Hcons.PosInt.make")
  90     else v
  91   let node v = v
  92   let hash v = v
  93   let uid v = Uid.of_int v
  94   let equal x y = x == y
  95   let init () = ()
  96 end