[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

Makefile.distrib

@@ -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
 

compile/compile.ml

+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)

compile/lambda.ml

+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
+*)

compile/operators.ml

+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

compile/operators.mli

+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

driver/cduce.ml

@@ -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

driver/cduce.mli

@@ -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

driver/run.ml

@@ -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 ];

misc/custom.ml

@@ -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

misc/encodings.ml

@@ -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

misc/encodings.mli

@@ -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

misc/ns.ml

@@ -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

misc/ns.mli

@@ -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

misc/pool.ml

@@ -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

misc/pool.mli

@@ -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

misc/serialize.ml

@@ -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
+
+
+
+

misc/serialize.mli

@@ -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