Commit bb3efc53 authored by Pietro Abate's avatar Pietro Abate

[r2003-09-27 12:41:30 by cvscast] Serialization, new system for operators, ...

Original author: cvscast
Date: 2003-09-27 12:41:34+00:00
parent 9cf7af52
......@@ -66,7 +66,7 @@ uninstall:
# Source directories
DIRS = misc parser schema typing types runtime driver module
DIRS = misc parser schema typing types compile runtime driver module
CLEAN_DIRS = $(DIRS) tools tests
# Objects to build
......@@ -92,8 +92,11 @@ OBJECTS = \
\
typing/typed.cmo typing/typer.cmo \
\
compile/lambda.cmo compile/compile.cmo \
\
runtime/load_xml.cmo runtime/run_dispatch.cmo \
runtime/print_xml.cmo runtime/eval.cmo \
compile/operators.cmo \
\
types/builtin.cmo driver/cduce.cmo
......
open Ident
open Lambda
type env = {
vars: var_loc Env.t;
stack_size: int
}
let empty = { vars = Env.empty; stack_size = 0 }
let rec compile env e = compile_aux env e.Typed.exp_descr
and compile_aux env = function
| Typed.Forget (e,_) -> compile env e
| Typed.Var x -> Var (Env.find x env.vars)
| Typed.Apply (e1,e2) -> Apply (compile env e1, compile env e2)
| Typed.Abstraction a -> compile_abstr env a
| Typed.Cst c -> Const c
| Typed.Pair (e1,e2) -> Pair(compile env e1, compile env e2)
| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) ->
let env' = env in
Xml (compile env e1, compile env' e2, compile env' e3)
| Typed.Xml (_,_) -> assert false
| Typed.RecordLitt r -> Record (LabelMap.map (compile env) r)
| Typed.String (i,j,s,q) -> String (i,j,s,compile env q)
| Typed.Match (e,brs) -> Match (compile env e, compile_branches env brs)
| _ -> assert false
and compile_abstr env a =
let (slots,nb_slots,fun_env) =
List.fold_left
(fun (slots,nb_slots,fun_env) x ->
match Env.find x env.vars with
| (Stack _ | Env _) as p ->
p::slots,
succ nb_slots,
Env.add x (Env nb_slots) fun_env;
| Global _ as p ->
slots,
nb_slots,
Env.add x p fun_env
| Dummy -> assert false
)
([],0,Env.empty) (IdSet.get a.Typed.fun_fv) in
let recurs,fun_env,slots = match a.Typed.fun_name with
| Some x when IdSet.mem a.Typed.fun_fv x ->
true, Env.add x (Env 0) fun_env, Dummy::slots
| _ -> false, fun_env, slots in
let slots = Array.of_list (List.rev slots) in
let env = { vars = fun_env; stack_size = 0 } in
let body = compile_branches env a.Typed.fun_body in
Abstraction (recurs, slots, a.Typed.fun_iface, body)
and compile_branches env (brs : Typed.branches) =
{
brs = List.map (compile_branch env) brs.Typed.br_branches;
brs_input = brs.Typed.br_typ;
brs_compiled = None
}
and compile_branch env br =
let env =
List.fold_left
(fun env x ->
{ vars = Env.add x (Stack env.stack_size) env.vars;
stack_size = env.stack_size + 1 }
) env (IdSet.get (Patterns.fv br.Typed.br_pat)) in
(br.Typed.br_pat, compile env br.Typed.br_body)
open Ident
type var_loc =
| Stack of int
| Env of int
| Global of int
| Dummy
type expr =
| Var of var_loc
| Apply of expr * expr
| Abstraction of bool * var_loc array * (Types.t * Types.t) list * branches
| Const of Types.Const.t
| Pair of expr * expr
| Xml of expr * expr * expr
| Record of expr label_map
| String of U.uindex * U.uindex * U.t * expr
| Match of expr * branches
| Map of expr * branches
| Transform of expr * branches
| Xtrans of expr * branches
| Validate of expr * string * string
| RemoveField of expr * label
| Dot of expr * label
| Try of expr * branches
| UnaryOp of unary_op * expr
| BinaryOp of binary_op * expr
| Ref of expr * Types.t
and unary_op = id
and binary_op = id
and branches = {
brs: (Patterns.node * expr) list;
brs_input: Types.t;
mutable brs_compiled:
(Patterns.Compile.dispatcher * expr Patterns.Compile.rhs array) option
}
(*
(* Evaluator *)
let call_stack = ref []
let env = ref [| |]
let stack = ref (Array.create 1024 Value.Absent)
let global = ref (Array.create 1024 Value.Absent)
let frame = ref 0
let sp = ref 0
let set a i x =
let n = Array.length !a in
if i = n then (
let b = Array.create (n*2) Value.Absent in
Array.blit !a 0 b 0 n;
a := b
);
!a.(i) <- x
let eval_var env = function
| Env i -> env.(i)
| Global i -> !global.(i)
| Stack i -> !stack.(!frame + i)
| Dummy -> Value.Absent
let rec eval env = function
| Var x -> eval_var env x
| Apply (e1,e2) -> eval_apply (eval env e1) (eval env e2)
| Abstraction (recurs,slots,iface,body) ->
if recurs then
let local_env = Array.map (eval_var env) slots in
let a = Value.Abstraction (local_env,iface,body) in
local_env.(Array.length local_env - 1) <- a;
a
else
let local_env = Array.map eval_var slots in
Value.Abstraction (local_env,iface,body)
and eval_apply f arg =
match f with
| Value.Abstraction (local_env,_,body) -> eval_branches local_env body arg
| _ -> assert false
*)
open Location
type type_fun = Types.t -> bool -> Types.t
module Unary = struct
module Op = struct
type t = (loc -> type_fun -> type_fun) * (Value.t -> Value.t)
end
module Proxy = Custom.Proxy(Custom.String)(Typer)(Op)
include Pool.NoHash(Proxy)
let register name make typ run ser deser =
Proxy.register name make
{ Proxy.content = (fun x -> (typ x, run x));
Proxy.serialize = ser;
Proxy.deserialize = deser };;
Typer.mk_unary_op := (fun name env -> mk (Proxy.instantiate name env));;
Typer.typ_unary_op := (fun i -> fst (Proxy.content (value i)));;
Eval.eval_unary_op := (fun i -> snd (Proxy.content (value i)));;
end
module Binary = struct
module Op = struct
type t = (loc -> type_fun -> type_fun -> type_fun) *
(Value.t -> Value.t -> Value.t)
end
module Proxy = Custom.Proxy(Custom.String)(Typer)(Op)
include Pool.NoHash(Proxy)
let register name make typ run ser deser =
Proxy.register name make
{ Proxy.content = (fun x -> (typ x, run x));
Proxy.serialize = ser;
Proxy.deserialize = deser };;
Typer.mk_binary_op := (fun name env -> mk (Proxy.instantiate name env));;
Typer.typ_binary_op := (fun i -> fst (Proxy.content (value i)));;
Eval.eval_binary_op := (fun i -> snd (Proxy.content (value i)));;
end
open Location
type type_fun = Types.t -> bool -> Types.t
module Unary: sig
include Custom.T with type t = int
val register:
string ->
(Typer.t -> 'a) ->
('a -> loc -> type_fun -> type_fun) ->
('a -> Value.t -> Value.t) ->
('a Serialize.Put.f) ->
('a Serialize.Get.f) -> unit
end
module Binary: sig
include Custom.T with type t = int
val register:
string ->
(Typer.t -> 'a) ->
('a -> loc -> type_fun -> type_fun -> type_fun) ->
('a -> Value.t -> Value.t -> Value.t) ->
('a Serialize.Put.f) ->
('a Serialize.Get.f) -> unit
end
This diff is collapsed.
......@@ -35,7 +35,7 @@ let dump_env ppf =
Format.fprintf ppf "Namespace prefixes:@\n%a" Typer.dump_ns !typing_env;
Format.fprintf ppf "Namespace prefixes used for pretty-printing:@.%t"
Ns.InternalPrinter.dump;
Format.fprintf ppf "Values:@\n";
Format.fprintf ppf "Values:@.";
Env.iter
(fun x v ->
let t = Typer.find_value x !typing_env in
......@@ -226,3 +226,9 @@ let run rule ppf ppf_err input =
let script = run Parser.prog
let topinput = run Parser.top_phrases
let serialize_typing_env t () =
Typer.serialize t !typing_env
let deserialize_typing_env t =
typing_env := Typer.deserialize t
......@@ -6,3 +6,6 @@ val script : Format.formatter -> Format.formatter -> char Stream.t -> bool
val topinput : Format.formatter -> Format.formatter -> char Stream.t -> bool
val dump_env : Format.formatter -> unit
val serialize_typing_env : Serialize.Put.t -> unit -> unit
val deserialize_typing_env : Serialize.Get.t -> unit
......@@ -143,7 +143,8 @@ let main () =
let chan = open_in_bin f in
let s = Marshal.from_channel chan in
close_in chan;
State.set s;
(* Serialize.Get.run Cduce.deserialize_typing_env s; *)
State.set s;
Format.fprintf ppf "done ...@."
with Sys_error _ ->
Format.fprintf ppf "failed ...@.")
......@@ -159,6 +160,7 @@ let main () =
(match !save_dump with
| Some f ->
Format.fprintf ppf "Saving state ...@\n";
(* let s = Serialize.Put.run Cduce.serialize_typing_env () in *)
let s = State.get () in
let chan = open_out_bin f in
Marshal.to_channel chan s [ Marshal.Closures ];
......
......@@ -117,3 +117,66 @@ module Pair(X : T)(Y : T) = struct
let serialize t x = Serialize.Put.pair X.serialize Y.serialize t x
let deserialize t = Serialize.Get.pair X.deserialize Y.deserialize t
end
module type Proxy = sig
include T
type key
type content
type arg
type 'a spec = {
content: 'a -> content;
serialize: 'a Serialize.Put.f;
deserialize: 'a Serialize.Get.f;
}
val register: key -> (arg -> 'a) -> 'a spec -> unit
val instantiate: key -> arg -> t
val content: t -> content
end
module Proxy(Key : T)(Arg : sig type t end)(Content : sig type t end) :
Proxy with type key = Key.t and type arg = Arg.t and type content = Content.t =
struct
type key = Key.t
type arg = Arg.t
type content = Content.t
type 'a spec = {
content: 'a -> Content.t;
serialize: 'a Serialize.Put.f;
deserialize: 'a Serialize.Get.f;
}
type t = {
value: content;
put: Serialize.Put.t -> unit;
}
include Dummy
module T = Hashtbl.Make(Key)
let table = T.create 23
let register name make spec =
let f r = {
value = spec.content r;
put = (fun s -> Key.serialize s name; spec.serialize s r)
} in
let deserialize s = f (spec.deserialize s) in
T.add table name
((fun arg -> f (make arg)),
(fun s -> f (spec.deserialize s)))
let content x = x.value
let instantiate name (arg : Arg.t) =
fst (T.find table name) arg
let serialize s x =
x.put s
let deserialize s =
let name = Key.deserialize s in
snd (T.find table name) s
end
......@@ -2,13 +2,9 @@ type uchar = int
module Utf8 =
struct
type t = string
include Custom.String
type uindex = int
let hash = Hashtbl.hash
let equal (x : t) y = x = y
let compare (x : t) y = compare x y
(* TODO: handle UTF-8 viewport *)
let to_string s =
......@@ -73,7 +69,11 @@ struct
check s (i+4) j
| _ -> false
let check s = check s 0 (String.length s)
let is_valid s = check s 0 (String.length s)
let check s = assert (is_valid s)
let mk_check s =
if is_valid s then Some (mk s) else None
let get s i =
match s.[i] with
......@@ -180,4 +180,7 @@ struct
s.[3] <- Char.chr (0x80 lor (p land 0x3f));
s
let serialize_sub t s i j =
Serialize.Put.substring t s i (j - i)
end
......@@ -2,15 +2,10 @@ type uchar = int
module Utf8 :
sig
type t
include Custom.T
type uindex
val hash: t -> int
val equal: t -> t -> bool
val compare: t -> t -> int
val check: string -> bool
val mk_check: string -> t option
val to_string: t -> string
val print: Format.formatter -> t -> unit
......@@ -31,4 +26,6 @@ sig
val store: Buffer.t -> uchar -> unit
val copy: Buffer.t -> t -> uindex -> uindex -> unit
val get_substr: t -> uindex -> uindex -> string
val serialize_sub: Serialize.Put.t -> t -> uindex -> uindex -> unit
end
......@@ -24,6 +24,26 @@ module Table = Map.Make(U)
type table = t Table.t
let serialize_table s table =
Table.iter
(fun prefix ns ->
Serialize.Put.bool s true;
U.serialize s prefix;
P.serialize s ns
) table;
Serialize.Put.bool s false
let deserialize_table s =
let rec aux table =
if not (Serialize.Get.bool s) then table
else
let prefix = U.deserialize s in
let ns = P.deserialize s in
aux (Table.add prefix ns table)
in
aux Table.empty
(* TODO: avoid re-inserting the same hint for the same
namespace ==> otherwise memory leak with load_xml ... *)
let global_hints = State.ref "Ns.prefixes" (Hashtbl.create 63)
......@@ -43,6 +63,9 @@ let dump_table ppf table =
type qname = t * U.t
exception UnknownPrefix of U.t
let map_prefix table pr =
try Table.find pr table
......@@ -208,3 +231,10 @@ struct
Format.fprintf ppf "%a=>\"%a\"@." U.print pr U.print (value ns)
) (Printer.prefixes !p)
end
module QName = struct
include Custom.Pair(P)(U)
let to_string x = InternalPrinter.attr x
let print ppf x = Format.fprintf ppf "%s" (to_string x)
let dump = print
end
......@@ -8,8 +8,16 @@ val value: t -> Utf8.t
val empty : t
type qname = t * Utf8.t
module QName : sig
include Custom.T with type t = qname
val to_string: t -> string
val print: Format.formatter -> t -> unit
end
type table (* prefix => namespace *)
val serialize_table: table Serialize.Put.f
val deserialize_table: table Serialize.Get.f
val empty_table: table (* Contains only xml *)
val add_prefix: Utf8.t -> t -> table -> table
val dump_table: Format.formatter -> table -> unit
......
......@@ -11,7 +11,7 @@ sig
val value: t -> value
end
module Make(H : Hashtbl.HashedType) =
module Make(H : Custom.T) =
struct
include Custom.Int
type value = H.t
......@@ -21,13 +21,15 @@ struct
let cache = State.ref "Pool.cache" (Tbl.create 63)
let values = State.ref "Pool.values" (Array.create 63 None)
let counter = State.ref "Pool.counter" 0
let check x = assert (!values.(x) <> None)
let clear () =
Tbl.clear !cache;
values := Array.create 63 None;
counter := 0
let check i =
assert((i >= 0) && (i < !counter) && (!values.(i) <> None))
let mk x =
try Tbl.find !cache x
with Not_found ->
......@@ -47,5 +49,90 @@ struct
let dummy_max = max_int
let value n = match !values.(n) with Some x -> x | None -> assert false
let memo =
Serialize.Put.mk_property (fun t -> Array.create !counter false)
let serialize t i =
let memo = Serialize.Put.get_property memo t in
Serialize.Put.int t i;
if not memo.(i) then (
H.serialize t (value i);
memo.(i) <- true
)
(* Use an array here ? *)
module DMemo = Map.Make(Custom.Int)
let memo = Serialize.Get.mk_property (fun t -> ref DMemo.empty)
let deserialize t =
let memo = Serialize.Get.get_property memo t in
let i = Serialize.Get.int t in
try DMemo.find i !memo
with Not_found ->
let j = mk (H.deserialize t) in
memo := DMemo.add i j !memo;
j
end
module NoHash(H : Custom.T) =
struct
include Custom.Int
type value = H.t
let values = State.ref "Pool.values" (Array.create 63 None)
let counter = State.ref "Pool.counter" 0
let clear () =
values := Array.create 63 None;
counter := 0
let check i =
assert((i >= 0) && (i < !counter) && (!values.(i) <> None))
let mk x =
let n = !counter in
incr counter;
if (n = Array.length !values) then
(
let new_values = Array.create (2 * Array.length !values) None in
Array.blit !values 0 new_values 0 n;
values := new_values
);
!values.(n) <- Some x;
n
let dummy_min = -1
let dummy_max = max_int
let value n = match !values.(n) with Some x -> x | None -> assert false
let memo =
Serialize.Put.mk_property (fun t -> Array.create !counter false)
let serialize t i =
let memo = Serialize.Put.get_property memo t in
Serialize.Put.int t i;
if not memo.(i) then (
H.serialize t (value i);
memo.(i) <- true
)
(* Use an array here ? *)
module DMemo = Map.Make(Custom.Int)
let memo = Serialize.Get.mk_property (fun t -> ref DMemo.empty)
let deserialize t =
let memo = Serialize.Get.get_property memo t in
let i = Serialize.Get.int t in
try DMemo.find i !memo
with Not_found ->
let j = mk (H.deserialize t) in
memo := DMemo.add i j !memo;
j
end
......@@ -19,5 +19,6 @@ sig
val value: t -> value
end
module Make(H : Hashtbl.HashedType) : T with type value = H.t and type t = int
module Make(H : Custom.T) : T with type value = H.t and type t = int
module NoHash(H : Custom.T) : T with type value = H.t and type t = int
......@@ -4,13 +4,24 @@ module Put = struct
mutable cur_byte : int; (* 0..255 *)
mutable cur_bits : int; (* 0..7 *)
}
let pos t = t.cur_bits + 8 * Buffer.length t.buf
type 'a f = t -> 'a -> unit
type 'b property = (t * 'b) list ref
let properties = ref []
let get_property prop t = List.assq t !prop
let get_property prop t =
match !prop with
| (s,x) :: _ when t == s -> x
| l ->
let x = List.assq t l in
prop := (t,x) :: (List.remove_assq t l);
x
(* Put in front of the list for quick access ... *)
let mk_property init =
let prop = ref [] in
properties :=
......@@ -38,18 +49,21 @@ module Put = struct
let rec bits nb t i = (* TODO: opt *)
if (nb > 0) then (bool t ((i land 1) <> 0); bits (pred nb) t (i lsr 1))
(* TODO: handle negative ints better !! *)
let rec int t i =
bits 4 t i;
let i = i lsr 4 in
if i <> 0 then (bool t true; int t i) else (bool t false)
let string t s =
let l = String.length s in
int t l;
for i = 0 to l - 1 do
let substring t s pos len =
int t len;
for i = pos to pos + len - 1 do
bits 8 t (Char.code (s.[i]))
done
let string t s =
substring t s 0 (String.length s)
let rec list f t = function
| [] -> bool t false
| hd::tl -> bool t true; f t hd; list f t tl
......@@ -61,10 +75,39 @@ end
module Get = struct
type t = { buf : string; mutable idx : int; mutable idx_bits : int }
let pos t = t.idx_bits + 8 * t.idx
type 'a f = t -> 'a
type 'b property = (t * 'b) list ref
let properties = ref []
let get_property prop t =
match !prop with
| (s,x) :: _ when t == s -> x
| l ->
let x = List.assq t l in
prop := (t,x) :: (List.remove_assq t l);
x
(* Put in front of the list for quick access ... *)
let mk_property init =
let prop = ref [] in
properties :=
((fun t -> prop := (t, init t) :: !prop),
(fun t -> prop := List.remove_assq t !prop)) :: !properties;
prop
let run f s =
f { buf = s; idx = 0; idx_bits = 0 }
let t = { buf = s; idx = 0; idx_bits = 0 } in
List.iter (fun (f,_) -> f t) !properties;
let res = f t in
List.iter (fun (_,f) -> f t) !properties;
res
let bool t =
let b = ((Char.code t.buf.[t.idx]) lsr t.idx_bits) land 1 <> 0 in
......@@ -100,3 +143,7 @@ module Get = struct
let y = f2 t in
(x,y)
end
......@@ -6,6 +6,7 @@ module Put : sig
val bits: int -> int f
val int: int f
val string: string f
val substring: t -> string -> int -> int -> unit
val bool: bool f