forked from camlspotter/ocamloscope
-
Notifications
You must be signed in to change notification settings - Fork 0
/
stype_pool.ml
98 lines (85 loc) · 2.42 KB
/
stype_pool.ml
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
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
(* The pool of types *)
(* Currently we have 500k types in the db
but it contains only 350k unique types.
Top 2400 types of 350k uniques are shared more than 10 times.
Top 17800 types are shared more than 3 times.
Top 58000 types are shared at least once.
We can skip lots of type matches by avoiding the same matches
against the shared types.
*)
open Spotlib.Spot
open List
open Item
module M = struct
include Hashtbl.Make(Stype_hcons.HashedType)
let to_list t =
let r = ref [] in
iter (fun k v -> r +::= (k,v)) t;
!r
end
let build items =
let tbl = M.create 1023 in
Array.iter (fun i ->
match Item.type_of_item i with
| None -> ()
| Some ty ->
try
let (count, p) = M.find tbl ty in
M.replace tbl ty (count+1, p)
with
| Not_found ->
M.add tbl ty (1, ref (-1) (* will be filled by the pos *))) items;
!!% "Type pool:@.";
!!% "%d different types@." & M.length tbl;
let sorted = List.sort (fun (_, (c,_)) (_, (c',_)) -> compare c' c) & M.to_list tbl in
let top = 20000 in
let a = Array.create top Stype.Nil in
let rec f i = function
| [] -> ()
| _ when i >= top -> ()
| (t, (_,r))::ts ->
Array.unsafe_set a i t;
r := i;
f (i+1) ts
in
f 0 sorted;
a,
fun ty ->
try
match M.find tbl ty with
| (_, { contents = (-1) }) -> None
| (_, { contents = n }) -> Some n
with Not_found -> None
let wrap_kind wrap = function
| Class -> Class
| ClassType -> ClassType
| ClassField (vf, ty) -> ClassField (vf, wrap ty)
| Constr ty -> Constr (wrap ty)
| Exception ty -> Exception (wrap ty)
| Field ty -> Field (wrap ty)
| Method (pv, vf, ty) -> Method (pv, vf, wrap ty)
| ModType -> ModType
| Module -> Module
| Type (tys, tyopt, k) -> Type (map wrap tys, Option.map wrap tyopt, k)
| Value ty -> Value (wrap ty)
| Package (ps,xs) -> Package (ps,xs)
let wrap_item wrap i = { i with kind = wrap_kind wrap i.kind }
let poolize items =
let a, f = build items in
let wrap ty =
match f ty with
| None -> Not_pooled ty
| Some n -> Pooled n
in
Array.map (wrap_item wrap) items,
a
let poolize items =
XSpotlib.Base.timed_message
(!% "Making type pool (%d items)" (Array.length items))
poolize items
let unpool_item a i =
let wrap = function
| Not_pooled ty -> ty
| Pooled i -> Array.unsafe_get a i
in
wrap_item wrap i