serial.ml 2.04 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
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)
  
  let lst = ref [] and nb = ref (-1)
  let put x = lst := x :: !lst; incr nb; !nb
    
  let init () = lst := []; nb := (-1)
  let serialize s = Serialize.Put.array X.serialize s 
		      (Array.of_list (List.rev !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)
34
35

module P = struct
36
37
38
  let init () = 
    PM.init ();
    CONST.init ()
39

40
41
42
  let serialize s () =
    PM.serialize s;
    CONST.serialize s
43

44
45
46
47
48
49
50
  let pm = PM.put
  let const = CONST.put

  let mk () =
    let s = Serialize.Put.run serialize () in
    ignore (Types.CompUnit.close_serialize ());
    s
51
52
53
54

end

module G = struct
55
56
57
58
59
60
61
62
63
64
65
  type chunk =
      { pm :
	  (Patterns.Compile.dispatcher * int Patterns.Compile.rhs array)
	  PM.chunk;
	cst : Value.t CONST.chunk;
      }

  let deserialize s =
    let pm = PM.deserialize s in
    let cst = CONST.deserialize s in
    { pm = pm; cst = cst }
66
67

  let mk s = 
68
69
70
71
72
73
74
    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
75

76
77
  let pm chunk i v =
    let (d,rhs) = PM.get mk_pm chunk.pm i in
78
79
    let (code,bindings) = Run_dispatch.run_dispatcher d v in
    match rhs.(code) with
80
      | Patterns.Compile.Fail -> (-1,[||])
81
82
83
84
85
      | Patterns.Compile.Match (bind,i) ->
	  i,
	  Array.map
	    (fun (_,i) -> if (i == -1) then v else bindings.(i))
	    (Array.of_list bind)
86
87
88
89


  let const chunk i =
    CONST.get Value.const chunk.cst i
90
	  
91
end
92