Commit 096d499a authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-04-04 14:09:43 by cvscast] Empty log message

Original author: cvscast
Date: 2003-04-04 14:09:45+00:00
parent 064293d2
......@@ -12,22 +12,22 @@ parser/location.cmo: parser/location.cmi
parser/location.cmx: parser/location.cmi
parser/parser.cmo: parser/ast.cmo types/atoms.cmi types/builtin.cmo \
types/chars.cmi types/ident.cmo types/intervals.cmi parser/location.cmi \
types/sequence.cmi types/types.cmi parser/wlexer.cmo parser/parser.cmi
types/sequence.cmi types/types.cmi parser/parser.cmi
parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/builtin.cmx \
types/chars.cmx types/ident.cmx types/intervals.cmx parser/location.cmx \
types/sequence.cmx types/types.cmx parser/wlexer.cmx parser/parser.cmi
parser/wlexer.cmo: parser/location.cmi
parser/wlexer.cmx: parser/location.cmx
types/sequence.cmx types/types.cmx parser/parser.cmi
typing/typed.cmo: types/ident.cmo parser/location.cmi types/patterns.cmi \
types/types.cmi
typing/typed.cmx: types/ident.cmx parser/location.cmx types/patterns.cmx \
types/types.cmx
typing/typer.cmo: parser/ast.cmo types/builtin.cmo types/ident.cmo \
types/intervals.cmi parser/location.cmi types/patterns.cmi \
types/sequence.cmi typing/typed.cmo types/types.cmi typing/typer.cmi
types/sequence.cmi misc/state.cmi typing/typed.cmo types/types.cmi \
typing/typer.cmi
typing/typer.cmx: parser/ast.cmx types/builtin.cmx types/ident.cmx \
types/intervals.cmx parser/location.cmx types/patterns.cmx \
types/sequence.cmx typing/typed.cmx types/types.cmx typing/typer.cmi
types/sequence.cmx misc/state.cmx typing/typed.cmx types/types.cmx \
typing/typer.cmi
types/atoms.cmo: misc/pool.cmi types/sortedList.cmi types/atoms.cmi
types/atoms.cmx: misc/pool.cmx types/sortedList.cmx types/atoms.cmi
types/boolean.cmo: types/sortedList.cmi types/boolean.cmi
......@@ -45,29 +45,23 @@ types/intervals.cmx: types/intervals.cmi
types/normal.cmo: types/normal.cmi
types/normal.cmx: types/normal.cmi
types/patterns.cmo: types/atoms.cmi types/chars.cmi types/ident.cmo \
types/sortedList.cmi types/sortedMap.cmi misc/state.cmi types/types.cmi \
types/patterns.cmi
types/sortedList.cmi misc/state.cmi types/types.cmi types/patterns.cmi
types/patterns.cmx: types/atoms.cmx types/chars.cmx types/ident.cmx \
types/sortedList.cmx types/sortedMap.cmx misc/state.cmx types/types.cmx \
types/patterns.cmi
types/recursive_noshare.cmo: types/recursive.cmo misc/state.cmi
types/recursive_noshare.cmx: types/recursive.cmx misc/state.cmx
types/recursive_share.cmo: types/recursive.cmo misc/state.cmi
types/recursive_share.cmx: types/recursive.cmx misc/state.cmx
types/sortedList.cmx misc/state.cmx types/types.cmx types/patterns.cmi
types/sequence.cmo: types/atoms.cmi types/types.cmi types/sequence.cmi
types/sequence.cmx: types/atoms.cmx types/types.cmx types/sequence.cmi
types/sortedList.cmo: types/sortedList.cmi
types/sortedList.cmx: types/sortedList.cmi
types/sortedMap.cmo: types/sortedMap.cmi
types/sortedMap.cmx: types/sortedMap.cmi
types/type_bool.cmo: types/boolean.cmi types/recursive.cmo
types/type_bool.cmx: types/boolean.cmx types/recursive.cmx
types/type_bool.cmo: types/boolean.cmi
types/type_bool.cmx: types/boolean.cmx
types/types.cmo: types/atoms.cmi misc/bool.cmi types/chars.cmi \
types/ident.cmo types/intervals.cmi types/normal.cmi types/recursive.cmo \
types/sortedList.cmi misc/state.cmi types/types.cmi
types/ident.cmo types/intervals.cmi types/normal.cmi types/sortedList.cmi \
misc/state.cmi types/types.cmi
types/types.cmx: types/atoms.cmx misc/bool.cmx types/chars.cmx \
types/ident.cmx types/intervals.cmx types/normal.cmx types/recursive.cmx \
types/sortedList.cmx misc/state.cmx types/types.cmi
types/ident.cmx types/intervals.cmx types/normal.cmx types/sortedList.cmx \
misc/state.cmx types/types.cmi
runtime/eval.cmo: types/atoms.cmi types/ident.cmo types/intervals.cmi \
runtime/load_xml.cmi parser/location.cmi runtime/print_xml.cmo \
runtime/run_dispatch.cmi misc/state.cmi typing/typed.cmo \
......@@ -99,11 +93,11 @@ runtime/value.cmx: types/atoms.cmx types/builtin.cmx types/chars.cmx \
driver/cduce.cmo: parser/ast.cmo types/builtin.cmo runtime/eval.cmi \
types/ident.cmo parser/location.cmi parser/parser.cmi types/patterns.cmi \
misc/state.cmi typing/typed.cmo typing/typer.cmi types/types.cmi \
runtime/value.cmi parser/wlexer.cmo driver/cduce.cmi
runtime/value.cmi driver/cduce.cmi
driver/cduce.cmx: parser/ast.cmx types/builtin.cmx runtime/eval.cmx \
types/ident.cmx parser/location.cmx parser/parser.cmx types/patterns.cmx \
misc/state.cmx typing/typed.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx parser/wlexer.cmx driver/cduce.cmi
runtime/value.cmx driver/cduce.cmi
driver/run.cmo: driver/cduce.cmi parser/location.cmi misc/state.cmi \
types/types.cmi
driver/run.cmx: driver/cduce.cmx parser/location.cmx misc/state.cmx \
......@@ -122,12 +116,10 @@ types/patterns.cmi: types/atoms.cmi types/chars.cmi types/ident.cmo \
types/types.cmi
types/sequence.cmi: types/atoms.cmi types/types.cmi
types/sortedMap.cmi: types/sortedList.cmi
types/syntax.cmi: types/patterns.cmi types/types.cmi
types/types.cmi: types/atoms.cmi types/chars.cmi types/ident.cmo \
types/intervals.cmi
types/intervals.cmi types/sortedList.cmi
runtime/eval.cmi: types/ident.cmo typing/typed.cmo runtime/value.cmi
runtime/load_xml.cmi: runtime/value.cmi
runtime/run_dispatch.cmi: types/patterns.cmi runtime/value.cmi
runtime/value.cmi: types/atoms.cmi types/chars.cmi types/ident.cmo \
types/intervals.cmi types/types.cmi
driver/cduce.cmi: runtime/eval.cmi typing/typer.cmi
......@@ -849,7 +849,7 @@ struct
let accu = ref [] in
let aux i (res,x) = accu := (x, [i,res]) :: !accu in
Array.iteri (fun i -> Normal.NLineBasic.iter (aux i)) pl;
Types.DescrSList.Map.get (Types.DescrSList.Map.from_list (@) !accu) in
Types.DescrSList.Map.get (Types.DescrSList.Map.from_list (@) !accu) in
let t = Types.cap Normal.any_basic disp.t in
let accu = ref [] in
......
exception NotEqual
exception Incomplete
module type S =
sig
type 'a t
val map: ('a -> 'b) -> ('a t -> 'b t)
val equal: ('a -> 'a -> unit) -> ('a t -> 'a t -> unit)
(* equal checks that two terms are equal and raises NotEqual otherwise;
the first argument must be called to check equality of subterms *)
val iter: ('a -> unit) -> ('a t -> unit)
(* a valid definition is often:
let iter f a = ignore (map f a) *)
val hash: ('a -> int) -> ('a t -> int)
(* [hash] should behave correctly w.r.t [map], that is:
hash h (map f a) == hash (h \circ f) a
A valid definition is often:
let hash h a = Hashtbl.hash (map h a)
*)
val deep: int
(* specify the deepness of hashing; use a value large enough to
discriminate between most non-equivalent graphs;
deep = 3 or 4 may often be adequate. *)
end
module type Make = functor (X : S) ->
sig
type node
type descr = node X.t
val make: unit -> node
val define: node -> descr -> unit
val internalize: node -> node
val internalize_descr: descr -> descr
val id: node -> int
val descr: node -> descr
val hash_descr: descr -> int
val equal_descr: descr -> descr -> bool
val is_recurs: node -> bool
val is_recurs_descr: descr -> bool
end
(* A fast replacement of Recursive without sharing at all *)
open Recursive
module Make(X : S) =
struct
type node = {
id : int;
mutable descr : descr;
}
and descr = node X.t
let id n = n.id
let counter = State.ref "Recursive_noshare" 0
let make () =
incr counter;
{
id = !counter;
descr = Obj.magic 0;
}
let equal x y = x.id = y.id
let internalize n = n
let internalize_descr d = d
let descr n = n.descr
let define n d = n.descr <- d
let hash_descr d = X.hash (fun n -> n.id) d
let equal_descr d1 d2 =
(d1 == d2) ||
try
X.equal
(fun n1 n2 -> if n1.id <> n2.id then raise NotEqual)
d1 d2;
true
with NotEqual -> false
let is_recurs n =
true
let is_recurs_descr d =
try X.iter (fun n -> if is_recurs n then raise Exit) d; false
with Exit -> true
end
(* $Id: recursive_share.ml,v 1.3 2002/11/10 02:21:46 cvscast Exp $ *)
open Recursive
module Make(X : S) =
struct
type state = Undefined | Defined | Hashed | Intern
(* Two values of this type have either different id or the
same fields (but they are not necessarily == if they have the same id).
This ensures that Pervasives.compare always terminates in O(1). *)
type node_content = {
mutable id : int;
mutable descr : node X.t;
mutable hash : int;
mutable state : state;
mutable hashs : int array;
} and node = node_content ref
type descr = node X.t
(* To avoid the creation of closures when computing hash values.
Need some profiling to see how much we gain, and if
a complete inlining for small values of deep is better *)
let deep_hash_tab = Array.create (X.deep + 1)
(fun {contents=n} ->
if n.state = Undefined then raise Incomplete;
13
)
let _ =
for i = 1 to X.deep do
deep_hash_tab.(i) <-
(fun {contents=n} ->
if n.hashs.(i) <> max_int then n.hashs.(i) else
(if n.state = Undefined then raise Incomplete;
let r = X.hash deep_hash_tab.(i-1) n.descr in
let r = if r = max_int then max_int - 1 else r in
n.hashs.(i) <- r;
r)
)
done
let deep_hash = deep_hash_tab.(X.deep)
(*
let rec deep_hash_rec k n =
if n.state = Undefined then raise Incomplete;
if k = 0 then 1 else X.hash (deep_hash_rec (k-1)) n.descr
let deep_hash = deep_hash_rec X.deep *)
let hash ({contents=n} as nr) =
match n.state with
| Defined ->
n.hash <- (deep_hash nr) land max_int;
(* Up to OCaml 3.04, Hashtbl.Make requires hash to return
non-negative integers ... *)
n.state <- Hashed;
n.hash
| Undefined -> raise Incomplete
| Hashed | Intern -> n.hash
let id n = !n.id
let counter = State.ref "Recursive_share" 0
(* TODO: need to save the Hashtbl ... *)
let make () =
incr counter;
ref {
id = !counter;
descr = Obj.magic 0;
state = Undefined;
hash = 0;
hashs = Array.make (X.deep+1) max_int;
}
let c = Hashtbl.create 64
let rec equal_rec a b =
if (a != b) then
if (hash a <> hash b) then raise NotEqual else
let a = !a and b = !b in
if (a != b) then
match (a.state,b.state) with
| (Intern,Intern) -> raise NotEqual
| _ ->
let m = if a.id < b.id then (a.id,b.id) else (b.id,a.id) in
if not (Hashtbl.mem c m) then
(Hashtbl.add c m (); X.equal equal_rec a.descr b.descr)
let equal ({contents=a} as ar) ({contents=b} as br) =
match (a.state,b.state) with
| (Intern,Intern) -> a.id = b.id
| _ ->
let r = try equal_rec ar br; true with NotEqual -> false in
Hashtbl.clear c;
r
(* Possible optimization: if r = true, one knows
that all pairs in c are equal. Could merge them here ? *)
module Prehash = Hashtbl.Make
(struct
type t = node
let hash = hash
let equal = equal
end)
let known = Prehash.create 1023
let rec internalize (({contents=n} as nr) : node) =
match n.state with
| Intern -> nr
| Undefined -> raise Incomplete
| Hashed
| Defined ->
(
try
let m = Prehash.find known nr in
nr := m;
nr
with Not_found ->
n.state <- Intern;
Prehash.add known nr n
;
n.descr <- X.map internalize n.descr;
nr
(* Cannot change descr ! If copied to another node, this would break (=) !!! *)
)
let internalize_descr = X.map internalize
let descr {contents=n} =
if n.state = Undefined then raise Incomplete else n.descr
let define ({contents=n} as nr) d =
if n.state != Undefined then failwith "Already defined";
n.state <- Defined;
n.descr <- d;
(* Special support for bottom-up hash-consing non-recursive objects *)
try
X.iter (fun m -> if !m.state <> Intern then raise Exit) d;
ignore (internalize nr)
with Exit -> ()
let hash_descr d = X.hash (fun n -> !n.id) d
let equal_descr d1 d2 =
(d1 == d2) ||
try
X.equal
(fun n1 n2 -> if !n1.id <> !n2.id then raise NotEqual)
d1 d2;
true
with NotEqual -> false
end
type t
val parse: string -> t
val make_type: t -> Types.node
val make_pat: t -> Patterns.node
open Recursive
open Printf
open Ident
(* IDEAS for optimizations:
* optimize lines of dnf for products and record;
instead of
(t1,s1) & ... & (tn,sn) \ ....
use:
(t1 & ... & tn, s1 & ... & sn) \ ....
---> more compact representation, more sharing, ...
* re-consider using BDD-like representation instead of dnf
*)
module HashedString =
struct
type t = string
......
......@@ -30,9 +30,6 @@ module DescrHash: Hashtbl.S with type key = descr
module DescrSList: SortedList.S with type 'a elem = descr
module DescrMap: Map.S with type key = descr
(* Note: it seems that even for non-functional data, DescrMap
is more efficient than DescrHash ... *)
(** Boolean connectives **)
val cup : descr -> descr -> descr
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment