Source

mutated_ocaml / typing / spot.ml

The branch 'ocamlspot-3120' does not exist.
Full commit
  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
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
(* This module is extended in ocamlspot, therefore it cannot be .mli *)

(* Annotations 

   Annotations are stored in .spot with their locations
*)

let magic_number = "OCamlSpot"
let ocaml_version = "3.12.0"
let version = "1.2"

module Location_bound = struct
  open Location
  let upperbound loc by = { loc with loc_end = by.loc_start }
end

module List = struct
  include List

  let filter_map f lst =
  List.rev (List.fold_left (fun st x ->
    match f x with
    | Some v -> v :: st
    | None -> st) [] lst)
end

module Kind = struct
  type t = 
    | Value | Type | Exception 
    | Module | Module_type 
    | Class | Class_type
end

module Abstraction = struct
  (* module definition abstraction *)

  (* CR jfuruse: types may be incompatible between compiler versions *)
  type module_expr = 
    | Mod_ident of Path.t (* module M = N *)
    | Mod_packed of string (* full path *)
        (* -pack overrides load paths: ocamlc -pack dir1/dir2/dir3/x.cmo *)
    | Mod_structure of structure (* module M = struct ... end *)
    | Mod_functor of Ident.t * Types.module_type * module_expr (* module M(I:S) = *)
    | Mod_apply of module_expr * module_expr (* module M = N(O) *)
    | Mod_constraint of module_expr * Types.module_type
    | Mod_unpack of Types.module_type
    | Mod_abstract (* used for Tmodtype_abstract *)

  (* structure abstraction : name - defloc asoc list *)
  and structure = structure_item list

  (* modtype must be identified from module, since they can have the
     same name *) 

  and structure_item = 
    | Str_value of Ident.t
    | Str_type of Ident.t
    | Str_exception of Ident.t
    | Str_module of Ident.t * module_expr
    | Str_modtype of Ident.t * module_expr
    | Str_class of Ident.t
    | Str_cltype of Ident.t
    | Str_include of module_expr * (Kind.t * Ident.t) list

  module Module_expr = struct
    (* cache key is Typedtree.module_expr *)
    module M = struct
      type t = Typedtree.module_expr
      let equal m1 m2 = m1 == m2
      let hash_source m = m.Typedtree.mod_loc
      let hash m = Hashtbl.hash (hash_source m)
    end
    include M
    module Table = Hashtbl.Make(M)
  end

  module Structure_item = struct
    (* cache key is Abstraction.structure_item, not Typedtree.structure_item *)
    module M = struct
      type t = structure_item
      let equal s1 s2 =
	match s1, s2 with
	| Str_value id1, Str_value id2 
	| Str_type id1, Str_type id2 
	| Str_exception id1, Str_exception id2
	| Str_class id1, Str_class id2
	| Str_cltype id1, Str_cltype id2 -> id1 = id2
	| Str_module (id1, mexp1) , Str_module (id2, mexp2) ->
	    id1 = id2 && Module_expr.equal mexp1 mexp2
	| Str_modtype (id1, mty1), Str_modtype (id2, mty2) ->
            id1 = id2 && Module_expr.equal mty1 mty2
	| Str_include (mexp1, kids1), Str_include (mexp2, kids2) ->
	    Module_expr.equal mexp1 mexp2 && kids1 = kids2
	| (Str_value _ | Str_type _ | Str_exception _ | Str_modtype _ 
	  | Str_class _ | Str_cltype _ | Str_module _ | Str_include _),
	  (Str_value _ | Str_type _ | Str_exception _ | Str_modtype _ 
	  | Str_class _ | Str_cltype _ | Str_module _ | Str_include _) -> false

      let hash = Hashtbl.hash
    end
    include M
    module Table = Hashtbl.Make(M)
  end

  open Types
  open Typedtree

  let cache_module_expr = Module_expr.Table.create 31
  let cache_structure_item = Structure_item.Table.create 31

  let included_sig_identifier_table = Hashtbl.create 31

  let kident_of_sigitem = function
    | Tsig_value (id, _) -> Kind.Value, id
    | Tsig_exception (id, _) -> Kind.Exception, id
    | Tsig_module (id, _, _) ->  Kind.Module, id
    | Tsig_class (id, _, _) -> Kind.Class, id
    | Tsig_type (id, _, _) -> Kind.Type, id
    | Tsig_modtype (id, _) -> Kind.Module_type, id
    | Tsig_cltype (id, _, _) -> Kind.Class_type, id

  let rec module_expr mexp =
    try
      match Module_expr.Table.find cache_module_expr mexp with
      | None ->
          (* When a module definition finds itself in itself.
             Impossible to happen, so far. *)
          assert false
      | Some v -> v
    with
    | Not_found ->
	Module_expr.Table.replace cache_module_expr mexp None;
	let res = module_expr_sub mexp in
	Module_expr.Table.replace cache_module_expr mexp (Some res);
        res

  and module_expr_sub mexp = 
    match mexp.mod_desc with
    | Tmod_ident p -> Mod_ident p
    | Tmod_structure str ->
	(* This may recompute abstractions of structure_items.
	   It sounds inefficient but not so much actually, since
	   module_expr is nicely cached. *)
	Mod_structure (List.flatten (List.map structure_item str))
    | Tmod_functor (id, mty, mexp) ->
        let mty = Mtype.scrape mexp.mod_env mty in
	Mod_functor(id, mty, module_expr mexp)
    | Tmod_apply (mexp1, mexp2, _mcoercion) -> (* CR jfuruse ? *)
	Mod_apply (module_expr mexp1, module_expr mexp2)
    | Tmod_constraint (mexp, mty, _mcoercion) ->
	Mod_constraint (module_expr mexp, mty)
    | Tmod_unpack (_expr, mty) -> Mod_unpack mty

  and structure_item sitem = 
    (* it may recompute the same thing, but it is cheap *)
    let sitems = structure_item_sub sitem in
    (* make the same result (==) *)
    let equalize sitem =
      try
	Structure_item.Table.find cache_structure_item sitem
      with
      | Not_found -> 
	  Structure_item.Table.replace cache_structure_item sitem sitem;
	  sitem
    in
    List.map equalize sitems
    
  and structure_item_sub = function
    | Tstr_eval _ -> []
    | Tstr_value (_, pat_exps) ->
	List.map (fun id -> Str_value id) (let_bound_idents pat_exps)
    | Tstr_primitive (id, _vdesc) -> 
	[Str_value id]
    | Tstr_type (id_descs) -> 
	List.map (fun (id, _) -> Str_type id) id_descs 
    | Tstr_exception (id ,_) ->
	[Str_exception id]
    | Tstr_exn_rebind (id, _path) -> (* CR jfuruse: path? *)
	[Str_exception id]
    | Tstr_module (id, mexp) ->
	[Str_module (id, module_expr mexp)]
    | Tstr_recmodule (idmexps) ->
	List.map (fun (id, mexp) ->
	  Str_module (id, module_expr mexp)) idmexps
    | Tstr_modtype (id, mty) ->
	[Str_modtype (id, module_type mty)]
    | Tstr_open _ -> []
    | Tstr_class classdescs ->
	List.map (fun (id, _, _, _, _) -> Str_class id) classdescs
    | Tstr_cltype iddecls ->
	List.map (fun (id, _) -> Str_cltype id) iddecls
    | Tstr_include (mexp, _ids, sg) ->
	let kids = List.map kident_of_sigitem sg in
        [Str_include (module_expr mexp, kids)]

  (* CR jfuruse: caching like module_expr_sub *)
  and module_type = function
    | Tmty_ident p -> Mod_ident p
    | Tmty_signature sg -> 
	Mod_structure (List.filter_map signature_item sg)
    | Tmty_functor (id, mty1, mty2) ->
        (* CR jfuruse: need to scrape ? but how ? *)
        Mod_functor(id, mty1, module_type mty2)

  and signature_item sitem = 
    try
      match sitem with
      | Tsig_value (id, _)
      | Tsig_type (id, _, _)
      | Tsig_exception (id, _)
      | Tsig_module (id, _ , _)
      | Tsig_modtype (id, _)
      | Tsig_class (id, _, _)
      | Tsig_cltype (id, _, _) ->
	  (* Sigitem might be defined by include, but it is not recorded
	     in signature. We here try to recover it. *)
	  (* CR jfuruse: included modules may listed more than once *)
	  let sitem, recorded = Hashtbl.find included_sig_identifier_table id in
          if !recorded then None
          else begin
            recorded := true;
            Some sitem
          end
    with
    | Not_found ->  Some (signature_item_sub sitem)
	
  and signature_item_sub = function
    | Tsig_value (id, _) -> Str_value id
    | Tsig_type (id, _, _) -> Str_type id
    | Tsig_exception (id, _) -> Str_exception id
    | Tsig_module (id, mty , _) -> Str_module (id, module_type mty)
    | Tsig_modtype (id, mty_decl) -> (* todo *) Str_modtype (id, modtype_declaration mty_decl)
    | Tsig_class (id, _, _) -> Str_class id
    | Tsig_cltype (id, _, _) -> Str_cltype id

  and modtype_declaration = function
    | Tmodtype_abstract -> Mod_abstract
    | Tmodtype_manifest mty -> module_type mty

end

let protect name f v =
  try f v with e ->
    Format.eprintf "Error: %s: %s@." name (Printexc.to_string e)
    
module Annot = struct
  type t =
    | Type of Types.type_expr (* sub-expression's type *)
    | Str of Abstraction.structure_item 
    | Use of Kind.t * Path.t
    | Module of Abstraction.module_expr
    | Functor_parameter of Ident.t
    | Non_expansive of bool
    | Mod_type of Types.module_type

  let equal t1 t2 =
    match t1, t2 with
    | Type t1, Type t2 -> t1 == t2
    | Mod_type mty1, Mod_type mty2 -> mty1 == mty2
    | Str sitem1, Str sitem2 -> Abstraction.Structure_item.equal sitem1 sitem2
    | Module mexp1, Module mexp2 -> mexp1 == mexp2
    | Use (k1,p1), Use (k2,p2) -> k1 = k2 && p1 = p2
    | Non_expansive b1, Non_expansive b2 -> b1 = b2
    | Functor_parameter id1, Functor_parameter id2 -> id1 = id2
    | (Type _ | Str _ | Module _ | Functor_parameter _ | Use _ | Non_expansive _ 
          | Mod_type _),
      (Type _ | Str _ | Module _ | Functor_parameter _ | Use _ | Non_expansive _
          | Mod_type _) -> false 

  (* CR jfuruse: A Location.t contains a filename, though it is always
     unique. Waste of 4xn bytes. *)
  let recorded = (Hashtbl.create 1023 : (Location.t, (int * t list)) Hashtbl.t)

  let clear () = Hashtbl.clear recorded

  let record loc t = 
    if !Clflags.annotations then begin
      let num_records, records = 
        try Hashtbl.find recorded loc with Not_found -> 0, []
      in
      (* This caching works horribly when too many things are defined 
         at the same locations. For example, a type definition of more than 
         3000 variants, with sexp camlp4 extension, the compile time explodes
         from 10secs to 4mins! Therefore this works 
         only if [num_records <= 10] 
      *)
      if num_records <= 10 && List.exists (equal t) records then ()
      else Hashtbl.replace recorded loc (num_records + 1, t :: records)
    end

  let record_constr_type_use loc ty =
    let path_of_constr_type t =
      let t = Ctype.repr t in 
      match (Ctype.repr t).Types.desc with
      | Types.Tconstr (p, _, _) -> Some p
      | _ ->
          Format.eprintf "Error: Spot.Annot.record_constr_type_use: not a constructor type: %a@." Printtyp.type_expr ty;
          None
    in
    match path_of_constr_type ty with
    | Some path -> record loc (Use (Kind.Type, path))
    | None -> ()

  let record_module_expr_def loc id modl =
    protect "Spot.Annot.record_module_expr_def" (fun () ->
      record loc (Str (Abstraction.Str_module 
	                  (id, 
	                  (Abstraction.module_expr modl)))))
      ()
    
  let record_module_expr_use loc modl =
    protect "Spot.Annot.record_module_expr_use" (fun () ->
      record loc (Module (Abstraction.module_expr modl));
      record loc (Mod_type modl.Typedtree.mod_type))
      ()

  let record_include loc modl sg =
    protect "Spot.Annot.record_include" (fun () ->
      List.iter (fun sitem -> record loc (Str sitem))
        (Abstraction.structure_item
            (Typedtree.Tstr_include (modl, [] (* not used *), sg))))
      ()

  let record_include_sig loc mty sg =
    protect "Spot.Annot.record_include_sig" (fun () ->
      let kids = (* CR jfuruse: copy of structure_item_sub *) 
	List.map Abstraction.kident_of_sigitem sg
      in
      let sitem = Abstraction.Str_include (Abstraction.module_type mty, kids)
      in 
      (* ocaml signature simply forgets the fact that kids are
	 included. We memorize them here. *)
      List.iter (fun (_,id) ->
	Hashtbl.add
          Abstraction.included_sig_identifier_table
	  id (sitem, ref false (* never recorded in the parent sig yet *))) kids;
      record loc (Str sitem))
      ()

  let record_module_expr_def loc id modl =
    protect "Spot.Annot.record_module_expr_def" (fun () ->
      record loc (Str (Abstraction.Str_module 
	                  (id, 
	                  (Abstraction.module_expr modl))));
      record loc (Mod_type modl.Typedtree.mod_type))
      ()
    
  let record_module_type_def loc id mty =
    protect "Spot.Annot.record_module_type_def" (fun () ->
      record loc (Str (Abstraction.Str_modtype
                          (id,
                          Abstraction.module_type mty))))
      ()
      
  let recorded () = Hashtbl.fold (fun k (_,vs) st -> 
    List.map (fun v -> k,v) vs @ st) recorded []
end

module Top = struct
  let recorded = ref None
  let clear () = recorded := None

  let record_structure str = 
    if !Clflags.annotations then begin
      assert (!recorded = None); 
      recorded := 
	Some (List.flatten (List.map Abstraction.structure_item str))
    end

  let record_structure = protect "Spot.Top.record_structure" record_structure 
    
  let record_signature sg = 
    if !Clflags.annotations then begin
      assert (!recorded = None); 
      recorded := 
	Some (List.filter_map Abstraction.signature_item sg)
    end

  let record_signature = protect "Spot.Top.record_signature" record_signature
    
  let recorded () = !recorded
end

(* Spot file *)
module File = struct
  (* not record but list for future exetensibility *)
  type elem =
    | Argv of string array
    | Source_path of string option (* packed module has None *)
    | Cwd of string
    | Load_paths of string list
    | Top of Abstraction.structure option
    | Annots of (Location.t * Annot.t) list

  (* marshalled type *)
  type t = elem list

  let write_to_oc ~source implementation annots oc =
    protect "Spot.File.write_to_oc" (fun () ->
      let source = 
        match source with
        | None -> None
        | Some p -> Some (Filename.concat (Sys.getcwd ()) p)
      in
      output_string oc magic_number;
      output_value oc (ocaml_version, version);
      Marshal.to_channel oc 
        [ Argv Sys.argv;
	  Source_path source;
          Cwd (Sys.getcwd ());
	  Load_paths !Config.load_path;
          Top implementation;
	  Annots annots ]
        [] (* keep sharing *))
      ()

  let write ~source implementation annots spot_file =
    protect "Spot.File.write" (fun () ->
      let oc = open_out_bin spot_file in
      write_to_oc ~source implementation annots oc;
      close_out oc) ()

  (* we must clear all the recorded after any dump of a compilation unit, 
     since the compiler may handle more than one .ml *)
  let clear () =
    Top.clear ();
    Annot.clear ();
    Abstraction.Module_expr.Table.clear Abstraction.cache_module_expr;
    Abstraction.Structure_item.Table.clear Abstraction.cache_structure_item
      
  let dump ~source spot_file =
    if !Clflags.annotations then 
      write ~source (Top.recorded ()) (Annot.recorded ()) spot_file;
    clear ()
  ;;

  (* -pack can pack modules out of include path: 
     ocamlc -pack -o p.cmo dir/m.cmo
  *)
  let dump_package ~prefix ~source files =
    if !Clflags.annotations then begin
      write ~source:(Some source)
        (Some (List.map (fun f -> 
          let module_name = 
            String.capitalize (Filename.chop_extension (Filename.basename f))
          in
          Abstraction.Str_module (Ident.create module_name, (* CR jfuruse: stamp is bogus *)
                                 Abstraction.Mod_packed f)) files))
        [] 
        (prefix ^ ".spot")
    end;
    clear ()
end