231 lines
7.2 KiB
OCaml
231 lines
7.2 KiB
OCaml
(**************************************************************************)
|
|
(* *)
|
|
(* OCaml *)
|
|
(* *)
|
|
(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 2006 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique. *)
|
|
(* *)
|
|
(* All rights reserved. This file is distributed under the terms of *)
|
|
(* the GNU Lesser General Public License version 2.1, with the *)
|
|
(* special exception on linking described in the file LICENSE. *)
|
|
(* *)
|
|
(**************************************************************************)
|
|
|
|
open! Int_replace_polymorphic_compare
|
|
open Lexing
|
|
open Location
|
|
|
|
module Scoped_location = struct
|
|
type scope_item =
|
|
| Sc_anonymous_function
|
|
| Sc_value_definition of string
|
|
| Sc_module_definition of string
|
|
| Sc_class_definition of string
|
|
| Sc_method_definition of string
|
|
|
|
type scopes = scope_item list
|
|
|
|
let add_parens_if_symbolic = function
|
|
| "" -> ""
|
|
| s ->
|
|
match s.[0] with
|
|
| 'a'..'z' | 'A'..'Z' | '_' | '0'..'9' -> s
|
|
| _ -> "(" ^ s ^ ")"
|
|
|
|
let string_of_scope_item = function
|
|
| Sc_anonymous_function ->
|
|
"(fun)"
|
|
| Sc_value_definition name
|
|
| Sc_module_definition name
|
|
| Sc_class_definition name
|
|
| Sc_method_definition name ->
|
|
add_parens_if_symbolic name
|
|
|
|
let string_of_scopes scopes =
|
|
let dot acc =
|
|
match acc with
|
|
| [] -> []
|
|
| acc -> "." :: acc in
|
|
let rec to_strings acc = function
|
|
| [] -> acc
|
|
(* Collapse nested anonymous function scopes *)
|
|
| Sc_anonymous_function :: ((Sc_anonymous_function :: _) as rest) ->
|
|
to_strings acc rest
|
|
(* Use class#meth syntax for classes *)
|
|
| (Sc_method_definition _ as meth) ::
|
|
(Sc_class_definition _ as cls) :: rest ->
|
|
to_strings (string_of_scope_item cls :: "#" ::
|
|
string_of_scope_item meth :: dot acc) rest
|
|
| s :: rest ->
|
|
to_strings (string_of_scope_item s :: dot acc) rest in
|
|
match scopes with
|
|
| [] -> "<unknown>"
|
|
| scopes -> String.concat "" (to_strings [] scopes)
|
|
|
|
let enter_anonymous_function ~scopes =
|
|
Sc_anonymous_function :: scopes
|
|
let enter_value_definition ~scopes id =
|
|
Sc_value_definition (Ident.name id) :: scopes
|
|
let enter_module_definition ~scopes id =
|
|
Sc_module_definition (Ident.name id) :: scopes
|
|
let enter_class_definition ~scopes id =
|
|
Sc_class_definition (Ident.name id) :: scopes
|
|
let enter_method_definition ~scopes (m : Asttypes.label) =
|
|
Sc_method_definition m :: scopes
|
|
|
|
type t =
|
|
| Loc_unknown
|
|
| Loc_known of
|
|
{ loc : Location.t;
|
|
scopes : scopes; }
|
|
|
|
let of_location ~scopes loc =
|
|
if Location.is_none loc then
|
|
Loc_unknown
|
|
else
|
|
Loc_known { loc; scopes }
|
|
|
|
let to_location = function
|
|
| Loc_unknown -> Location.none
|
|
| Loc_known { loc; _ } -> loc
|
|
|
|
let string_of_scoped_location = function
|
|
| Loc_unknown -> "??"
|
|
| Loc_known { loc = _; scopes } -> string_of_scopes scopes
|
|
end
|
|
|
|
type item = {
|
|
dinfo_file: string;
|
|
dinfo_line: int;
|
|
dinfo_char_start: int;
|
|
dinfo_char_end: int;
|
|
dinfo_start_bol: int;
|
|
dinfo_end_bol: int;
|
|
dinfo_end_line: int;
|
|
dinfo_scopes: Scoped_location.scopes;
|
|
}
|
|
|
|
type t = item list
|
|
|
|
type alloc_dbginfo_item =
|
|
{ alloc_words : int;
|
|
alloc_dbg : t }
|
|
type alloc_dbginfo = alloc_dbginfo_item list
|
|
|
|
let none = []
|
|
|
|
let is_none = function
|
|
| [] -> true
|
|
| _ :: _ -> false
|
|
|
|
let to_string dbg =
|
|
match dbg with
|
|
| [] -> ""
|
|
| ds ->
|
|
let items =
|
|
List.map
|
|
(fun d ->
|
|
Printf.sprintf "%s:%d,%d-%d"
|
|
d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end)
|
|
ds
|
|
in
|
|
"{" ^ String.concat ";" items ^ "}"
|
|
|
|
let item_from_location ~scopes loc =
|
|
let valid_endpos =
|
|
String.equal loc.loc_end.pos_fname loc.loc_start.pos_fname in
|
|
{ dinfo_file = loc.loc_start.pos_fname;
|
|
dinfo_line = loc.loc_start.pos_lnum;
|
|
dinfo_char_start = loc.loc_start.pos_cnum - loc.loc_start.pos_bol;
|
|
dinfo_char_end =
|
|
if valid_endpos
|
|
then loc.loc_end.pos_cnum - loc.loc_start.pos_bol
|
|
else loc.loc_start.pos_cnum - loc.loc_start.pos_bol;
|
|
dinfo_start_bol = loc.loc_start.pos_bol;
|
|
dinfo_end_bol =
|
|
if valid_endpos then loc.loc_end.pos_bol
|
|
else loc.loc_start.pos_bol;
|
|
dinfo_end_line =
|
|
if valid_endpos then loc.loc_end.pos_lnum
|
|
else loc.loc_start.pos_lnum;
|
|
dinfo_scopes = scopes
|
|
}
|
|
|
|
let from_location = function
|
|
| Scoped_location.Loc_unknown -> []
|
|
| Scoped_location.Loc_known {scopes; loc} ->
|
|
assert (not (Location.is_none loc));
|
|
[item_from_location ~scopes loc]
|
|
|
|
let to_location = function
|
|
| [] -> Location.none
|
|
| d :: _ ->
|
|
let loc_start =
|
|
{ pos_fname = d.dinfo_file;
|
|
pos_lnum = d.dinfo_line;
|
|
pos_bol = d.dinfo_start_bol;
|
|
pos_cnum = d.dinfo_start_bol + d.dinfo_char_start;
|
|
} in
|
|
let loc_end =
|
|
{ pos_fname = d.dinfo_file;
|
|
pos_lnum = d.dinfo_end_line;
|
|
pos_bol = d.dinfo_end_bol;
|
|
pos_cnum = d.dinfo_start_bol + d.dinfo_char_end;
|
|
} in
|
|
{ loc_ghost = false; loc_start; loc_end; }
|
|
|
|
let inline dbg1 dbg2 =
|
|
dbg1 @ dbg2
|
|
|
|
(* CR-someday afrisch: FWIW, the current compare function does not seem very
|
|
good, since it reverses the two lists. I don't know how long the lists are,
|
|
nor if the specific currently implemented ordering is useful in other
|
|
contexts, but if one wants to use Map, a more efficient comparison should
|
|
be considered. *)
|
|
let compare dbg1 dbg2 =
|
|
let rec loop ds1 ds2 =
|
|
match ds1, ds2 with
|
|
| [], [] -> 0
|
|
| _ :: _, [] -> 1
|
|
| [], _ :: _ -> -1
|
|
| d1 :: ds1, d2 :: ds2 ->
|
|
let c = String.compare d1.dinfo_file d2.dinfo_file in
|
|
if c <> 0 then c else
|
|
let c = compare d1.dinfo_line d2.dinfo_line in
|
|
if c <> 0 then c else
|
|
let c = compare d1.dinfo_char_end d2.dinfo_char_end in
|
|
if c <> 0 then c else
|
|
let c = compare d1.dinfo_char_start d2.dinfo_char_start in
|
|
if c <> 0 then c else
|
|
let c = compare d1.dinfo_start_bol d2.dinfo_start_bol in
|
|
if c <> 0 then c else
|
|
let c = compare d1.dinfo_end_bol d2.dinfo_end_bol in
|
|
if c <> 0 then c else
|
|
let c = compare d1.dinfo_end_line d2.dinfo_end_line in
|
|
if c <> 0 then c else
|
|
loop ds1 ds2
|
|
in
|
|
loop (List.rev dbg1) (List.rev dbg2)
|
|
|
|
let hash t =
|
|
List.fold_left (fun hash item -> Hashtbl.hash (hash, item)) 0 t
|
|
|
|
let rec print_compact ppf t =
|
|
let print_item item =
|
|
Format.fprintf ppf "%a:%i"
|
|
Location.print_filename item.dinfo_file
|
|
item.dinfo_line;
|
|
if item.dinfo_char_start >= 0 then begin
|
|
Format.fprintf ppf ",%i--%i" item.dinfo_char_start item.dinfo_char_end
|
|
end
|
|
in
|
|
match t with
|
|
| [] -> ()
|
|
| [item] -> print_item item
|
|
| item::t ->
|
|
print_item item;
|
|
Format.fprintf ppf ";";
|
|
print_compact ppf t
|