Commit 4401b3b6 authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Make the generated .cdo files compatible with 32 bits version of OCaml, and...

Make the generated .cdo files compatible with 32 bits version of OCaml, and hopefully with js_of_ocaml.
parent 5e3bf00a
......@@ -11,6 +11,6 @@ let () =
init ();
Cduce_config.init_all ();
Cduce_js.use ();
Cduce.compile_run "/static/main.cd"
Cduce.run "/static/main.cdo"
with
Invalid_argument "Function 'exit' not implemented" -> ()
......@@ -53,13 +53,13 @@ let has_obj n =
let base = U.to_string n ^ ".cdo" in
List.exists (fun p -> Sys.file_exists (Filename.concat p base)) !obj_path
let find_obj n =
let find_obj n =
let base = U.to_string n ^ ".cdo" in
let p =
let p =
List.find (fun p -> Sys.file_exists (Filename.concat p base)) !obj_path in
Filename.concat p base
let check_digest c dig =
let check_digest c dig =
if digest c <> dig then raise (InconsistentCrc c.name)
let show ppf id t v =
......@@ -67,35 +67,35 @@ let show ppf id t v =
| Some id ->
Format.fprintf ppf "@[val %a : @[%a@]@."
Ident.print id
Types.Print.pp_type t
Types.Print.pp_type t
| None -> ()
let compile verbose name src =
protect_op "Compile external file";
let ic =
let ic =
if src = "" then (Cduce_loc.push_source `Stream; stdin)
else
try Cduce_loc.push_source (`File src); open_in src
with Sys_error _ -> raise (CannotOpen src) in
let input = Stream.of_channel ic in
let p =
try Parser.prog input
let p =
try Parser.prog input
with
| Ulexer.Loc.Exc_located (_, (Location _ | Ulexer.Error _ as e)) -> raise e
| Ulexer.Loc.Exc_located ((i,j), e) ->
| Ulexer.Loc.Exc_located ((i,j), e) ->
raise_loc i j e
in
if src <> "" then close_in ic;
let show =
if verbose
if verbose
then Some (show Format.std_formatter)
else None in
Compunit.enter ();
let descr = Compunit.current () in
let (ty_env,c_env,code) =
Compile.comp_unit
Compile.comp_unit
?show
Builtin.env
(Compile.empty descr)
......@@ -108,8 +108,8 @@ let compile verbose name src =
let set_hash c =
let h = Hashtbl.hash_param 1000 10000 (c.typing,c.name) in
let max_rank =
Tbl.fold
let max_rank =
Tbl.fold
(fun _ c accu -> max accu (fst (Compunit.get_hash c.descr))) tbl 0 in
Compunit.set_hash c.descr (succ max_rank) h
(* This invalidates all hash tables on types ! *)
......@@ -120,18 +120,16 @@ let compile_save verbose name src out =
let c = compile verbose name src in
set_hash c;
let pools = Value.extract_all () in
let oc = open_out_bin out in
output_string oc magic;
Marshal.to_channel oc (pools,c) [];
Marshal.to_channel oc (pools,c) [Marshal.Compat_32];
let digest = Digest.file out in
Marshal.to_channel oc digest [];
Marshal.to_channel oc digest [Marshal.Compat_32];
close_out oc
let from_descr descr : t =
try CTbl.find ctbl descr
with Not_found ->
with Not_found ->
let i1,i2 = Compunit.get_hash descr in
failwith (Printf.sprintf "Can't find cu(%i,%i)" i1 i2)
......@@ -139,12 +137,12 @@ let register c =
(* Look for an already loaded unit with the same descriptor *)
if CTbl.mem ctbl c.descr then failwith "Collision on unit descriptors";
CTbl.add ctbl c.descr c
let reg_types = ref true
let rec real_load src =
let ic =
let ic =
try open_in_bin src
with Sys_error _ -> raise (CannotOpen src) in
try
......@@ -162,14 +160,14 @@ let rec real_load src =
and load name =
protect_op "Load compiled compilation unit";
try Tbl.find tbl name
with Not_found ->
let src =
with Not_found ->
let src =
try find_obj name
with Not_found -> raise (NoImplementation name) in
let c = real_load src in
register c;
(* Register types *)
if !reg_types then
if !reg_types then
Typer.register_types (U.to_string c.name ^ ".") c.typing;
(* Load dependencies *)
List.iter (fun (name,dig) -> check_digest (load name) dig) c.depends;
......@@ -180,7 +178,7 @@ let rec run c =
match c.status with
| `Unevaluated ->
if (c.ext_info != None) && (Array.length c.exts = 0) then
failwith (Printf.sprintf
failwith (Printf.sprintf
"The CDuce unit `%s' needs externals"
(U.to_string c.name));
......@@ -190,12 +188,12 @@ let rec run c =
c.status <- `Evaluating;
Eval.eval_unit c.vals c.code;
c.status <- `Evaluated
| `Evaluating ->
failwith
| `Evaluating ->
failwith
("Librarian.run. Already running:" ^ (U.to_string c.name))
| `Evaluated -> ()
let compile_run verbose name src =
let compile_run verbose name src =
let c = compile verbose name src in
register c;
run c
......@@ -203,17 +201,17 @@ let compile_run verbose name src =
let load_run name = reg_types := false; run (load name)
let static_externals = Hashtbl.create 17
let register_static_external n v =
let register_static_external n v =
Hashtbl.add static_externals n v
let get_builtins () =
List.sort Pervasives.compare
List.sort Pervasives.compare
(Hashtbl.fold (fun n _ accu -> n::accu) static_externals [])
let () =
Typer.from_comp_unit := (fun d -> (from_descr d).typing);
Typer.load_comp_unit := (fun name ->
if has_obj name then
Typer.load_comp_unit := (fun name ->
if has_obj name then
let cu = load name in
if !run_loaded then run cu;
cu.descr
......@@ -225,14 +223,14 @@ let () =
Eval.get_builtin := Hashtbl.find static_externals
let stub_ml = ref (fun _ _ _ _ _ ->
let stub_ml = ref (fun _ _ _ _ _ ->
Printf.eprintf
"Fatal error: no support for the OCaml interface.\n";
exit 2)
let prepare_stub src =
let c = real_load src in
(* Create stub types in a fresh compilation unit *)
Compunit.enter ();
let i1,i2 = Compunit.get_hash c.descr in
......@@ -240,7 +238,7 @@ let prepare_stub src =
!stub_ml (U.get_str c.name) c.typing c.compile c.ext_info
(fun types ->
Compunit.leave ();
Marshal.to_string (Value.extract_all (), types, c) [])
Marshal.to_string (Value.extract_all (), types, c) [Marshal.Compat_32])
(* TODO: could remove typing and compile env *)
let ocaml_stub stub =
......@@ -249,9 +247,9 @@ let ocaml_stub stub =
failwith ("CDuce unit " ^ (U.get_str c.name) ^ " already loaded");
Value.intract_all pools;
register c;
List.iter
(fun (name,dig) ->
let c =
List.iter
(fun (name,dig) ->
let c =
try Tbl.find tbl name
with Not_found ->
failwith ("CDuce unit " ^ (U.get_str name) ^ " not loaded")
......
......@@ -59,9 +59,9 @@ module String : T with type t = string = struct
accu := 223 * !accu + Char.code s.[i]
done;
(* reduce to 31 bits *)
accu := !accu land (1 lsl 31 - 1);
(* accu := *) !accu land 0x3fffffff;
(* make it signed for 64 bits architectures *)
if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
(*if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu *)
end
module Int : T with type t = int = struct
......@@ -70,7 +70,7 @@ module Int : T with type t = int = struct
let check s = ()
let equal : t -> t -> bool = (=)
let compare : t -> t -> int = Pervasives.compare
let hash x = x
let hash x = x land 0x3fffffff
end
module Bool : T with type t = bool = struct
......@@ -79,7 +79,7 @@ module Bool : T with type t = bool = struct
let check s = ()
let equal : t -> t -> bool = (=)
let compare : t -> t -> int = Pervasives.compare
let hash x = if x then 1 else 0
let hash (x : t) : int = Obj.magic x
end
module Array(X : T) = struct
......@@ -104,7 +104,7 @@ module Array(X : T) = struct
let hash a =
let h = ref (Array.length a) in
Array.iter (fun x -> h := 17 * !h + X.hash x) a;
!h
!h land 0x3fffffff
end
module List(X : T) = struct
......@@ -123,7 +123,7 @@ module List(X : T) = struct
| [] -> 1 + accu
| x::l -> hash (17 * accu + Elem.hash x) l
let hash l = hash 1 l
let hash l = (hash 1 l) land 0x3fffffff
let rec compare l1 l2 =
if l1 == l2 then 0
......@@ -143,7 +143,7 @@ module Pair(X : T)(Y : T) = struct
let c = X.compare x1 x2 in if c <> 0 then c
else Y.compare y1 y2
let equal (x1,y1) (x2,y2) = (X.equal x1 x2) && (Y.equal y1 y2)
let hash (x,y) = X.hash x + 65599 * Y.hash y
let hash (x,y) = (X.hash x + 65599 * Y.hash y) land 0x3fffffff
end
type ('a,'b) choice = Left of 'a | Right of 'b
......@@ -158,6 +158,8 @@ module Sum(X : T)(Y : T) = struct
let hash = function
| Left t1 -> 1 + 3 * X.hash t1
| Right t2 -> 2 + 3 * Y.hash t2
let hash x = (hash x) land 0x3fffffff
let compare t1 t2 =
match t1,t2 with
| Left t1, Left t2 -> X.compare t1 t2
......
......@@ -202,6 +202,8 @@ let hash f t =
+ (get_int t i)) (i - 2) in
aux 1 (get_len t - 2)
let hash f t = (hash f t) land 0x3fffffff
let remove t i =
if t == empty then t
else
......
......@@ -98,9 +98,15 @@ module Decompile(H : TABLE)(S : S) = struct
| APlus t -> 1 + 17 * (hash_trie t)
| ATrans t -> 2 + 17 * (S.hash t)
let rec hash_atom_list = function
| hd::tl -> hash_atom hd + 17 * (hash_atom_list tl)
| [] -> 0
let hash_atom a = (hash_atom a) land 0x3fffffff
let hash_atom_list l =
let rec loop l acc =
match l with
[] -> acc land 0x3fffffff
| hd :: tl -> loop tl (17 * acc + (hash_atom hd))
in
loop l 0
module T = struct
type t = atom list * trie * trie * int
......@@ -117,7 +123,7 @@ module Decompile(H : TABLE)(S : S) = struct
let uid = ref 0
let branch0 a ay an =
let h = hash_atom_list a + 17 * (hash_trie ay) + 257 * (hash_trie an) in
let h = (hash_atom_list a + 17 * (hash_trie ay) + 257 * (hash_trie an)) land 0x3fffffff in
let b = (a,ay,an,h) in
try HT.find branches b
with Not_found ->
......
......@@ -18,12 +18,7 @@ module type S = sig
val from_int: int -> t
end
module HInt =
Hashtbl.Make(struct
type t = int
let hash x = x
let equal x y = x==y
end)
module HInt = Hashtbl.Make(Custom.Int)
module Make(X : Custom.T) = struct
type token
......
......@@ -614,6 +614,8 @@ let rec hash = function
| String_latin1 (i,j,s,q) -> hash (normalize_string_latin1 i j s q)
| String_utf8 (i,j,s,q) ->hash (normalize_string_utf8 i j s q)
let hash v = (hash v) land 0x3fffffff
let iter_xml pcdata_callback other_callback =
let rec aux = function
| v when compare v nil = 0 -> ()
......
......@@ -74,7 +74,7 @@ struct
| Split(h, _,_,_,_) -> h
let compute_hash x p i n =
(X.hash x) + 17 * (hash p) + 257 * (hash i) + 16637 * (hash n)
((X.hash x) + 17 * (hash p) + 257 * (hash i) + 16637 * (hash n)) land 0x3fffffff
let rec check = function
| True | False -> ()
......@@ -86,7 +86,7 @@ struct
X.check x; check p; check i; check n
let atom x =
let h = X.hash x + 17 in (* partial evaluation of compute_hash... *)
let h = (X.hash x + 17) land 0x3fffffffff in (* partial evaluation of compute_hash... *)
Split (h, x,True,False,False)
......@@ -364,7 +364,7 @@ struct
let var v =
let compute_hash x p i n =
(Var.hash x) + 17 * (hash p) + 257 * (hash i) + 16637 * (hash n)
((Var.hash x) + 17 * (hash p) + 257 * (hash i) + 16637 * (hash n)) land 0x3fffffff
in
let a = atom (`Atm T.full) in
let h = compute_hash v a False False in
......
type t = { mutable rank: int; mutable hash: int }
let hash c = c.rank + 16 * c.hash
let hash c = (c.rank + 16 * c.hash) land 0x3fffffff
let equal c1 c2 = c1 == c2 || (c1.rank == c2.rank && c1.hash == c2.hash)
......@@ -18,7 +18,7 @@ let current () = !current_ref
let enter () =
assert(!current_ref == pervasives);
current_ref := { rank = max_int; hash = 0 }
current_ref := { rank = 0x3fffffff (* max_int *); hash = 0 }
let leave () =
assert(!current_ref != pervasives);
......
......@@ -4,7 +4,7 @@ module V = struct
(* Hack to compute hash value for bigints *)
let hash_nat x = Nat.nth_digit_nat x 0
let hash_bigint (sign,nat) = sign * 17 + hash_nat nat
let hash_bigint (sign,nat) = (sign * 17 + hash_nat nat) land 0x3fffffff
type t = big_int
let print ppf i = Format.fprintf ppf "%s" (string_of_big_int i)
......@@ -118,7 +118,7 @@ let rec hash accu = function
| Any :: _ -> 17 * accu + 1234
| [] -> accu + 3
let hash = hash 0
let hash i = (hash 0 i) land 0x3fffffff
let empty = []
let any = [Any]
......
......@@ -98,7 +98,9 @@ let counter = ref 0
let dummy = (Types.empty,IdSet.empty,Dummy)
let make fv =
incr counter;
{ id = !counter; descr = dummy; accept = Types.make (); fv = fv }
if !counter land 0x3fffffff == !counter then
{ id = !counter; descr = dummy; accept = Types.make (); fv = fv }
else failwith "Internal error in patterns.ml, l99 : counter overflow"
let define x ((accept,fv,_) as d) =
(* assert (x.fv = fv); *)
......@@ -203,6 +205,8 @@ module Pat = struct
| Constant (x,c) -> 8 + 17 * (Id.hash x) + 257 * (Types.Const.hash c)
| Dummy -> assert false
let hash v = (hash v) land 0x3fffffff
let check _ = assert false
let dump _ = assert false
end
......@@ -520,6 +524,9 @@ module Normal = struct
else IdSet.compare xs1 xs2
let hash (l,t,xs) =
(NodeSet.hash l) + 17 * (Types.hash t) + 257 * (IdSet.hash xs)
let hash v = (hash v) land 0x3fffffff
let equal x y = compare x y == 0
......
......@@ -97,7 +97,7 @@ module Make(X : Custom.T) = struct
| [] -> 1 + accu
| x::l -> hash (17 * accu + Elem.hash x) l
let hash l = hash 1 l
let hash l = (hash 1 l) land 0x3fffffff
let rec compare l1 l2 =
if l1 == l2 then 0
......@@ -454,6 +454,8 @@ module Make(X : Custom.T) = struct
| [] -> 1
| (x,y)::l -> Elem.hash x + 17 * (f y) + 257 * (hash f l)
let hash f l = (hash f l) land 0x3fffffff
let rec equal f l1 l2 =
(l1 == l2) ||
match (l1,l2) with
......@@ -481,7 +483,7 @@ module Make(X : Custom.T) = struct
(* Note: need to eta expand these definitions, because
of the compilation of the recursive module definitions
in types.ml... *)
let hash x = Map.hash Y.hash x
let hash x = (Map.hash Y.hash x) land 0x3fffffff
let compare x y = Map.compare Y.compare x y
let equal x y = Map.equal Y.equal x y
......@@ -524,6 +526,8 @@ module FiniteCofinite(X : Custom.T) = struct
| Finite l -> SList.hash l
| Cofinite l -> 17 * SList.hash l + 1
let hash l = (hash l) land 0x3fffffff
let compare l1 l2 =
match (l1,l2) with
| Finite l1, Finite l2
......@@ -665,6 +669,8 @@ struct
| Finite l -> 1 + 17 * (TMap.hash l)
| Cofinite l -> 2 + 17 * (TMap.hash l)
let hash l = (hash l) land 0x3fffffff
let compare l1 l2 =
match (l1,l2) with
| Finite l1, Finite l2
......
......@@ -97,6 +97,8 @@ module Const = struct
| String (i,j,s,r) -> 7 + 17 * (U.hash s) + 257 * hash r
(* Note: improve hash for String *)
let hash c = (hash c) land 0x3fffffff
let equal c1 c2 = compare c1 c2 = 0
end
......@@ -135,7 +137,7 @@ type type_kind = [ `atoms | `intervals | `chars | `times | `xml | `arrow | `reco
let pp_type_kind ppf k =
Format.fprintf ppf "%s" (match k with
`atoms -> "atoms"
`atoms -> "atoms"
| `intervals -> "intervals"
| `chars -> "chars"
| `times -> "times"
......@@ -287,7 +289,7 @@ struct
let accu = 17 * accu + VarRec.hash a.record in
let accu = 17 * accu + VarAbstracts.hash a.abstract in
let accu = if a.absent then accu+5 else accu in
accu
accu land 0x3fffffff
let get_absent t = t.absent
let set_absent t b = { t with absent = b }
......@@ -307,7 +309,7 @@ struct
type t = { id : int; cu: Compunit.t; mutable descr : Descr.t }
let check n = ()
let dump ppf n = Format.fprintf ppf "X%i" n.id
let hash x = x.id + Compunit.hash x.cu
let hash x = (x.id + Compunit.hash x.cu) land 0x3fffffff
let compare x y =
let c = x.id - y.id in if c = 0 then Compunit.compare x.cu y.cu else c
let equal x y = x==y || (x.id == y.id && (Compunit.equal x.cu y.cu))
......@@ -434,6 +436,8 @@ let forward_print = ref dummy_print
let make () =
incr count;
if !count != !count land 0x3fffffff then
failwith "Internal error in types.ml, l440 : counter overflow";
Node.mk !count empty
let define n d =
......@@ -678,6 +682,8 @@ module Witness = struct
)
| _ -> assert false
let hash w = (hash w) land 0x3fffffff
let equal_small w1 w2 = match w1,w2 with
| WInt i1, WInt i2 -> Intervals.V.equal i1 i2
| WChar c1, WChar c2 -> Chars.V.equal c1 c2
......@@ -1967,11 +1973,15 @@ module Print = struct
let memo = DescrHash.create 63
let counter = ref 0
let alloc def = {
id = (incr counter; !counter);
def = def;
state = `None;
}
let alloc def =
incr counter;
if (!counter land 0x3fffffff == !counter) then
{
id = !counter;
def = def;
state = `None;
}
else failwith "Internal error in types.ml, l1982 : counter overflow"
let count_name = ref 0
let name () =
......@@ -3124,7 +3134,7 @@ struct
x1 == x2
|| ((equiv t1 t2) && (Map.equal equiv m1 m2))
let hash (t, m) =
Descr.hash t + 17 * Map.hash Descr.hash m
(Descr.hash t + 17 * Map.hash Descr.hash m) land 0x3fffffff
end
)
......
......@@ -66,9 +66,13 @@ let gen set =
if ni == 0 then acc else pretty ni acc
in
let x = mk (pretty !idx "") in
if Set.mem set x then
(* if the name is taken by a variable in delta, restart *)
(incr idx; freshvar ())
if Set.mem set x then begin
(* if the name is taken by a variable in delta, restart *)
incr idx;
if !idx != !idx land 0x3fffffff then
failwith "Internal error in var.ml, l74 : counter overflow";
freshvar ();
end
else x
in
freshvar ()
......@@ -78,6 +82,7 @@ type 'a var_or_atom = [ `Atm of 'a | `Var of t ]
module Make (X : Custom.T) = struct
type t = X.t var_or_atom
let hash = function `Atm t -> 17 + 17 * X.hash t | `Var x -> 997 + 17 * V.hash x
let hash v = (hash v) land 0x3fffffff
let check = function `Atm t -> X.check t | `Var _ -> ()
......@@ -94,4 +99,3 @@ module Make (X : Custom.T) = struct
|`Atm x -> X.dump ppf x
|`Var x -> V.dump ppf x
end
......@@ -13,7 +13,7 @@ let deferr s = raise (Patterns.Error s)
mutable p: Patterns.descr option;
mutable pnode: Patterns.node option;
mutable fv: fv option
}
}
and desc =
| ILink of node
| IType of Types.descr * int
......@@ -33,7 +33,7 @@ let deferr s = raise (Patterns.Error s)
let concats = ref []
let rec node_temp = {
let rec node_temp = {
desc = ILink node_temp;
smallhash = 0; rechash = 0; sid = 0;
t = None; tnode = None; p = None; pnode = None;
......@@ -56,25 +56,26 @@ let deferr s = raise (Patterns.Error s)
let mk_constant n1 n2 = mk (IConstant (n1,n2))
let mk_concat ?(err=deferr) n1 n2 =
let n = mk (IConcat (n1,n2,err)) in concats := n :: !concats; n
let mk_merge ?(err=deferr) n1 n2 =