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 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;
     }

  let init () = 
    { pm = PM.init ();
      cst = CONST.init ();
      lab = LAB.init ();
      typ = T.init ();
      laba = LABA.init ();
      tag = TAG.init ();
      taga = TAGA.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;
    ()

  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 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;
      }

  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
    { pm = pm; cst = cst; lab = lab; typ = typ; laba = laba; tag = tag;
      taga = taga }

  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 t0 t v =
    let t0 = typ chunk t0 and t = typ chunk t in
    match Explain.explain t0 t v with
    | None -> v
    | Some p -> failwith (Explain.to_string p)
  

  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

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