trunk/runtime/serial.ml

(*
let cu = Types.CompUnit.mk (Encodings.Utf8.mk "OCAML")
let () = Types.CompUnit.enter cu; Types.caml_mode := true
let init = ref []
let serialize = ref []

module Mk(X : Custom.T) = struct
  module A = Custom.Array(X)
  
  type pchunk = { mutable nb : int; mutable lst : X.t list }
  let put c x = 
    let i = c.nb in
    c.nb <- succ i;
    c.lst <- x::c.lst;
    i
    
  let init () = { nb = 0; lst = [] }
  let serialize s c = Serialize.Put.array X.serialize s 
                      (Array.of_list (List.rev c.lst))

  type 'a entry = Serialized of X.t | Computed of 'a
  type 'a chunk = 'a entry array

  let deserialize s = 
    Serialize.Get.array (fun s -> Serialized (X.deserialize s)) s

  let get f a i =
    match a.(i) with
      | Serialized x ->
          let x = f x in
          a.(i) <- Computed x;
          x
      | Computed x ->
          x
end

module PM = Mk(Custom.Pair(Types)(Custom.List(Patterns.Node)))
module CONST = Mk(Types.Const)
module LAB = Mk(Ident.LabelPool)
module T = Mk(Types)
module T2 = Mk(Custom.Pair(Types)(Types))
module LABA = Mk(Custom.Array(Ident.LabelPool))
module TAG = Mk(Atoms.V)
module TAGA = Mk(Custom.Array(Custom.Pair(Atoms.V)(Custom.Int)))

module P = struct
  type chunk =
      { pm : PM.pchunk;
        cst : CONST.pchunk;
        lab : LAB.pchunk;
        typ : T.pchunk;
        laba : LABA.pchunk;
        tag : TAG.pchunk;
        taga : TAGA.pchunk;
        typ2 : T2.pchunk;
     }

  let init () = 
    { pm = PM.init ();
      cst = CONST.init ();
      lab = LAB.init ();
      typ = T.init ();
      laba = LABA.init ();
      tag = TAG.init ();
      taga = TAGA.init ();
      typ2 = T2.init ();
    }

  let serialize s c =
    PM.serialize s c.pm;
    CONST.serialize s c.cst;
    LAB.serialize s c.lab;
    T.serialize s c.typ;
    LABA.serialize s c.laba;
    TAG.serialize s c.tag;
    TAGA.serialize s c.taga;
    T2.serialize s c.typ2;
    ()

  let pm c = PM.put c.pm
  let const c = CONST.put c.cst
  let label c = LAB.put c.lab
  let typ c = T.put c.typ
  let label_array c = LABA.put c.laba
  let tag c = TAG.put c.tag
  let tag_array c = TAGA.put c.taga
  let typ2 c t1 t2 = T2.put c.typ2 (t1,t2)

  let mk c =
    let s = Serialize.Put.run serialize c in
    ignore (Types.CompUnit.close_serialize ());
    s

end

module G = struct
  type chunk =
      { pm :
          (Patterns.Compile.dispatcher * int Patterns.Compile.rhs array)
          PM.chunk;
        cst : Value.t CONST.chunk;
        lab : Ident.label LAB.chunk;
        typ : Types.t T.chunk;
        laba : Ident.label array LABA.chunk;
        tag : Value.t TAG.chunk;
        taga : int Atoms.map TAGA.chunk;
        typ2 : (Value.t -> unit) T2.chunk;
      }

  let deserialize s =
    let pm = PM.deserialize s in
    let cst = CONST.deserialize s in
    let lab = LAB.deserialize s in
    let typ = T.deserialize s in
    let laba = LABA.deserialize s in
    let tag = TAG.deserialize s in
    let taga = TAGA.deserialize s in
    let typ2 = T2.deserialize s in
    { pm = pm; cst = cst; lab = lab; typ = typ; laba = laba; tag = tag;
      taga = taga; typ2 = typ2 }

  let mk s = 
    Types.clear_deserialize_table ();
    Serialize.Get.run deserialize s

  let mk_pm (t,brs) =
    let brs = Array.to_list (Array.mapi (fun i x -> (x,i)) (Array.of_list brs))
    in
    Patterns.Compile.make_branches t brs

  let pm chunk i v =
    let (d,rhs) = PM.get mk_pm chunk.pm i in
    let (code,bindings) = Run_dispatch.run_dispatcher d v in
    match rhs.(code) with
      | Patterns.Compile.Fail -> (-1,[||])
      | Patterns.Compile.Match (bind,i) ->
          i,
          Array.map
            (fun (_,i) -> if (i == -1) then v else bindings.(i))
            (Array.of_list bind)


  let const chunk i =
    CONST.get Value.const chunk.cst i
          
  let remove_label chunk i v =
    Value.remove_field (LAB.get (fun x -> x) chunk.lab i) v
  let get_field chunk i v =
    Value.get_field v (LAB.get (fun x -> x) chunk.lab i)

  let typ chunk i =
    T.get (fun x -> x) chunk.typ i

  let check chunk i v =
    T2.get (fun (t0,t) -> Explain.check t0 t) chunk.typ2 i v;
    v

  let record chunk i vs =
    Value.mk_record (LABA.get (fun x -> x) chunk.laba i) vs

  let constr_const chunk i =
    TAG.get (fun x -> Value.Atom x) chunk.tag i

  let constr chunk i vs =
    Value.ocaml2cduce_constr (constr_const chunk i) vs

  let taga chunk i = 
    TAGA.get
      (fun x ->
         let x = Array.map (fun (t,i) ->
                              Atoms.atom t, i) x in
         Atoms.mk_map (Array.to_list x))
      chunk.taga i

  let dconstr chunk i v =
    Value.cduce2ocaml_constr (taga chunk i) v
  let dvariant chunk i v =
    Value.cduce2ocaml_variant (taga chunk i) v
end
*)

module P = struct
  type chunk = {
    mutable nb : int;
    mutable objs : Obj.t list
  }

  let init () = { nb = 0; objs = [] }

  let mk c =
    let o = Array.of_list (List.rev c.objs) in
    Marshal.to_string (Value.extract_all (), o) []

  let put c x =
    let i = c.nb in
    c.nb <- succ i;
    c.objs <- Obj.repr x :: c.objs;
    i
end

module G = struct
  let mk s =
    let (pools,objs) = Marshal.from_string s 0 in
    Value.intract_all pools;
    objs
end
1	(*
2	let cu = Types.CompUnit.mk (Encodings.Utf8.mk "OCAML")
3	let () = Types.CompUnit.enter cu; Types.caml_mode := true
4	let init = ref []
5	let serialize = ref []
6
7	module Mk(X : Custom.T) = struct
8	module A = Custom.Array(X)
9
10	type pchunk = { mutable nb : int; mutable lst : X.t list }
11	let put c x =
12	let i = c.nb in
13	c.nb <- succ i;
14	c.lst <- x::c.lst;
15	i
16
17	let init () = { nb = 0; lst = [] }
18	let serialize s c = Serialize.Put.array X.serialize s
19	(Array.of_list (List.rev c.lst))
20
21	type 'a entry = Serialized of X.t \| Computed of 'a
22	type 'a chunk = 'a entry array
23
24	let deserialize s =
25	Serialize.Get.array (fun s -> Serialized (X.deserialize s)) s
26
27	let get f a i =
28	match a.(i) with
29	\| Serialized x ->
30	let x = f x in
31	a.(i) <- Computed x;
32	x
33	\| Computed x ->
34	x
35	end
36
37	module PM = Mk(Custom.Pair(Types)(Custom.List(Patterns.Node)))
38	module CONST = Mk(Types.Const)
39	module LAB = Mk(Ident.LabelPool)
40	module T = Mk(Types)
41	module T2 = Mk(Custom.Pair(Types)(Types))
42	module LABA = Mk(Custom.Array(Ident.LabelPool))
43	module TAG = Mk(Atoms.V)
44	module TAGA = Mk(Custom.Array(Custom.Pair(Atoms.V)(Custom.Int)))
45
46	module P = struct
47	type chunk =
48	{ pm : PM.pchunk;
49	cst : CONST.pchunk;
50	lab : LAB.pchunk;
51	typ : T.pchunk;
52	laba : LABA.pchunk;
53	tag : TAG.pchunk;
54	taga : TAGA.pchunk;
55	typ2 : T2.pchunk;
56	}
57
58	let init () =
59	{ pm = PM.init ();
60	cst = CONST.init ();
61	lab = LAB.init ();
62	typ = T.init ();
63	laba = LABA.init ();
64	tag = TAG.init ();
65	taga = TAGA.init ();
66	typ2 = T2.init ();
67	}
68
69	let serialize s c =
70	PM.serialize s c.pm;
71	CONST.serialize s c.cst;
72	LAB.serialize s c.lab;
73	T.serialize s c.typ;
74	LABA.serialize s c.laba;
75	TAG.serialize s c.tag;
76	TAGA.serialize s c.taga;
77	T2.serialize s c.typ2;
78	()
79
80	let pm c = PM.put c.pm
81	let const c = CONST.put c.cst
82	let label c = LAB.put c.lab
83	let typ c = T.put c.typ
84	let label_array c = LABA.put c.laba
85	let tag c = TAG.put c.tag
86	let tag_array c = TAGA.put c.taga
87	let typ2 c t1 t2 = T2.put c.typ2 (t1,t2)
88
89	let mk c =
90	let s = Serialize.Put.run serialize c in
91	ignore (Types.CompUnit.close_serialize ());
92	s
93
94	end
95
96	module G = struct
97	type chunk =
98	{ pm :
99	(Patterns.Compile.dispatcher * int Patterns.Compile.rhs array)
100	PM.chunk;
101	cst : Value.t CONST.chunk;
102	lab : Ident.label LAB.chunk;
103	typ : Types.t T.chunk;
104	laba : Ident.label array LABA.chunk;
105	tag : Value.t TAG.chunk;
106	taga : int Atoms.map TAGA.chunk;
107	typ2 : (Value.t -> unit) T2.chunk;
108	}
109
110	let deserialize s =
111	let pm = PM.deserialize s in
112	let cst = CONST.deserialize s in
113	let lab = LAB.deserialize s in
114	let typ = T.deserialize s in
115	let laba = LABA.deserialize s in
116	let tag = TAG.deserialize s in
117	let taga = TAGA.deserialize s in
118	let typ2 = T2.deserialize s in
119	{ pm = pm; cst = cst; lab = lab; typ = typ; laba = laba; tag = tag;
120	taga = taga; typ2 = typ2 }
121
122	let mk s =
123	Types.clear_deserialize_table ();
124	Serialize.Get.run deserialize s
125
126	let mk_pm (t,brs) =
127	let brs = Array.to_list (Array.mapi (fun i x -> (x,i)) (Array.of_list brs))
128	in
129	Patterns.Compile.make_branches t brs
130
131	let pm chunk i v =
132	let (d,rhs) = PM.get mk_pm chunk.pm i in
133	let (code,bindings) = Run_dispatch.run_dispatcher d v in
134	match rhs.(code) with
135	\| Patterns.Compile.Fail -> (-1,[\|\|])
136	\| Patterns.Compile.Match (bind,i) ->
137	i,
138	Array.map
139	(fun (_,i) -> if (i == -1) then v else bindings.(i))
140	(Array.of_list bind)
141
142
143	let const chunk i =
144	CONST.get Value.const chunk.cst i
145
146	let remove_label chunk i v =
147	Value.remove_field (LAB.get (fun x -> x) chunk.lab i) v
148	let get_field chunk i v =
149	Value.get_field v (LAB.get (fun x -> x) chunk.lab i)
150
151	let typ chunk i =
152	T.get (fun x -> x) chunk.typ i
153
154	let check chunk i v =
155	T2.get (fun (t0,t) -> Explain.check t0 t) chunk.typ2 i v;
156	v
157
158	let record chunk i vs =
159	Value.mk_record (LABA.get (fun x -> x) chunk.laba i) vs
160
161	let constr_const chunk i =
162	TAG.get (fun x -> Value.Atom x) chunk.tag i
163
164	let constr chunk i vs =
165	Value.ocaml2cduce_constr (constr_const chunk i) vs
166
167	let taga chunk i =
168	TAGA.get
169	(fun x ->
170	let x = Array.map (fun (t,i) ->
171	Atoms.atom t, i) x in
172	Atoms.mk_map (Array.to_list x))
173	chunk.taga i
174
175	let dconstr chunk i v =
176	Value.cduce2ocaml_constr (taga chunk i) v
177	let dvariant chunk i v =
178	Value.cduce2ocaml_variant (taga chunk i) v
179	end
180	*)
181
182	module P = struct
183	type chunk = {
184	mutable nb : int;
185	mutable objs : Obj.t list
186	}
187
188	let init () = { nb = 0; objs = [] }
189
190	let mk c =
191	let o = Array.of_list (List.rev c.objs) in
192	Marshal.to_string (Value.extract_all (), o) []
193
194	let put c x =
195	let i = c.nb in
196	c.nb <- succ i;
197	c.objs <- Obj.repr x :: c.objs;
198	i
199	end
200
201	module G = struct
202	let mk s =
203	let (pools,objs) = Marshal.from_string s 0 in
204	Value.intract_all pools;
205	objs
206	end