Skip to content

Commit

Permalink
flambda-backend: Zero alloc: assume that works with inlining - propag…
Browse files Browse the repository at this point in the history 
…ate via Scoped_location (#1762)
  • Loading branch information
@gretay-js
gretay-js authored Sep 15, 2023
1 parent 263fa26 commit b9cf106
Show file tree
Hide file tree
Showing 8 changed files with 214 additions and 153 deletions.
18 changes: 10 additions & 8 deletions asmcomp/emitaux.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -166,17 +166,18 @@ let emit_frames a =
in
let module Label_table =
Hashtbl.Make (struct
type t = bool * Debuginfo.t
type t = bool * Debuginfo.Dbg.t

let equal ((rs1 : bool), dbg1) (rs2, dbg2) =
rs1 = rs2 && Debuginfo.compare dbg1 dbg2 = 0
rs1 = rs2 && Debuginfo.Dbg.compare dbg1 dbg2 = 0

let hash (rs, dbg) =
Hashtbl.hash (rs, Debuginfo.hash dbg)
Hashtbl.hash (rs, Debuginfo.Dbg.hash dbg)
end)
in
let debuginfos = Label_table.create 7 in
let label_debuginfos rs dbg =
let dbg = Debuginfo.get_dbg dbg in
let key = (rs, dbg) in
try Label_table.find debuginfos key
with Not_found ->
Expand All @@ -190,16 +191,17 @@ let emit_frames a =
then a.efa_16 n
else raise (Error(Stack_frame_too_large n))
in
let is_none_dbg d = Debuginfo.Dbg.is_none (Debuginfo.get_dbg d) in
let emit_frame fd =
assert (fd.fd_frame_size land 3 = 0);
let flags =
match fd.fd_debuginfo with
| Dbg_other d | Dbg_raise d ->
if Debuginfo.is_none d then 0 else 1
if is_none_dbg d then 0 else 1
| Dbg_alloc dbgs ->
if !Clflags.debug &&
List.exists (fun d ->
not (Debuginfo.is_none d.Debuginfo.alloc_dbg)) dbgs
not (is_none_dbg d.Debuginfo.alloc_dbg)) dbgs
then 3 else 2
in
a.efa_label_rel fd.fd_lbl 0l;
Expand Down Expand Up @@ -227,7 +229,7 @@ let emit_frames a =
if flags = 3 then begin
a.efa_align 4;
List.iter (fun Debuginfo.{alloc_dbg; _} ->
if Debuginfo.is_none alloc_dbg then
if is_none_dbg alloc_dbg then
a.efa_32 Int32.zero
else
a.efa_label_rel (label_debuginfos false alloc_dbg) Int32.zero) dbg
Expand Down Expand Up @@ -261,7 +263,7 @@ let emit_frames a =
(of_int has_next)))))
in
let emit_debuginfo (rs, dbg) lbl =
let rdbg = dbg |> Debuginfo.to_list |> List.rev in
let rdbg = dbg |> Debuginfo.Dbg.to_list |> List.rev in
(* Due to inlined functions, a single debuginfo may have multiple locations.
These are represented sequentially in memory (innermost frame first),
with the low bit of the packed debuginfo being 0 on the last entry. *)
Expand Down Expand Up @@ -346,7 +348,7 @@ let reset_debug_info () =
(* We only display .file if the file has not been seen before. We
display .loc for every instruction. *)
let emit_debug_info_gen dbg file_emitter loc_emitter =
let dbg = Debuginfo.to_list dbg in
let dbg = Debuginfo.Dbg.to_list (Debuginfo.get_dbg dbg) in
if is_cfi_enabled () &&
(!Clflags.debug || Config.with_frame_pointers) then begin
match List.rev dbg with
Expand Down
191 changes: 123 additions & 68 deletions lambda/debuginfo.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,7 +29,8 @@ module Scoped_location = struct

type scopes =
| Empty
| Cons of {item: scope_item; str: string; str_fun: string; name : string; prev: scopes}
| Cons of {item: scope_item; str: string; str_fun: string; name : string; prev: scopes;
assume_zero_alloc: bool}

let str = function
| Empty -> ""
Expand All @@ -39,8 +40,9 @@ module Scoped_location = struct
| Empty -> "(fun)"
| Cons r -> r.str_fun

let cons scopes item str name =
Cons {item; str; str_fun = str ^ ".(fun)"; name; prev = scopes}
let cons scopes item str name ~assume_zero_alloc =
Cons {item; str; str_fun = str ^ ".(fun)"; name; prev = scopes;
assume_zero_alloc}

let empty_scopes = Empty

Expand All @@ -61,39 +63,60 @@ module Scoped_location = struct
| Empty -> s
| Cons {str; _} -> str ^ sep ^ s

let enter_anonymous_function ~scopes =
let enter_anonymous_function ~scopes ~assume_zero_alloc =
let str = str_fun scopes in
Cons {item = Sc_anonymous_function; str; str_fun = str; name = ""; prev = scopes}
Cons {item = Sc_anonymous_function; str; str_fun = str; name = ""; prev = scopes;
assume_zero_alloc }

let enter_value_definition ~scopes id =
let enter_value_definition ~scopes ~assume_zero_alloc id =
cons scopes Sc_value_definition (dot scopes (Ident.name id)) (Ident.name id)
~assume_zero_alloc

let enter_compilation_unit ~scopes cu =
let name = Compilation_unit.name_as_string cu in
cons scopes Sc_module_definition (dot scopes name) name
~assume_zero_alloc:false

let enter_module_definition ~scopes id =
cons scopes Sc_module_definition (dot scopes (Ident.name id)) (Ident.name id)
~assume_zero_alloc:false

let enter_class_definition ~scopes id =
cons scopes Sc_class_definition (dot scopes (Ident.name id)) (Ident.name id)
~assume_zero_alloc:false

let enter_method_definition ~scopes (s : Asttypes.label) =
let str =
match scopes with
| Cons {item = Sc_class_definition; _} -> dot ~sep:"#" scopes s
| _ -> dot scopes s
in
cons scopes Sc_method_definition str s
cons scopes Sc_method_definition str s ~assume_zero_alloc:false

let enter_lazy ~scopes = cons scopes Sc_lazy (str scopes) ""
~assume_zero_alloc:false

let enter_partial_or_eta_wrapper ~scopes =
cons scopes Sc_partial_or_eta_wrapper (dot ~no_parens:() scopes "(partial)") ""
~assume_zero_alloc:false

let set_assume_zero_alloc ~scopes =
match scopes with
| Empty -> Empty
| Cons { assume_zero_alloc = true } -> scopes
| Cons { item; str; str_fun; name; prev; assume_zero_alloc = false; } ->
Cons { item; str; str_fun; name; prev; assume_zero_alloc = true; }

let get_assume_zero_alloc ~scopes =
match scopes with
| Empty -> false
| Cons { assume_zero_alloc; _ } -> assume_zero_alloc

let string_of_scopes = function
| Empty -> "<unknown>"
| Cons {str; _} -> str
| Cons {str; assume_zero_alloc; _} ->
if assume_zero_alloc then str^"(assume zero_alloc)"
else str

let string_of_scopes =
let module StringSet = Set.Make (String) in
Expand Down Expand Up @@ -143,32 +166,79 @@ type item = {
dinfo_scopes: Scoped_location.scopes;
}

type t = { dbg : item list; }
module Dbg = struct
type t = item list

(* 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 = Int.compare d1.dinfo_line d2.dinfo_line in
if c <> 0 then c else
let c = Int.compare d1.dinfo_char_end d2.dinfo_char_end in
if c <> 0 then c else
let c = Int.compare d1.dinfo_char_start d2.dinfo_char_start in
if c <> 0 then c else
let c = Int.compare d1.dinfo_start_bol d2.dinfo_start_bol in
if c <> 0 then c else
let c = Int.compare d1.dinfo_end_bol d2.dinfo_end_bol in
if c <> 0 then c else
let c = Int.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 is_none dbg =
match dbg with
| [] -> true
| _ :: _ -> false

let hash dbg =
List.fold_left (fun hash item -> Hashtbl.hash (hash, item)) 0 dbg

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 to_list t = t

let length t = List.length t

end

type t = { dbg : Dbg.t; assume_zero_alloc : bool }

type alloc_dbginfo_item =
{ alloc_words : int;
alloc_dbg : t }
type alloc_dbginfo = alloc_dbginfo_item list

let none = { dbg = []; }
let none = { dbg = []; assume_zero_alloc = false }

let is_none { dbg } =
match dbg with
| [] -> 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 to_string { dbg; assume_zero_alloc; } =
let s = Dbg.to_string dbg in
if assume_zero_alloc then s^"(assume zero_alloc)" else s

let item_from_location ~scopes loc =
let valid_endpos =
Expand All @@ -191,12 +261,13 @@ let item_from_location ~scopes loc =
}

let from_location = function
| Scoped_location.Loc_unknown -> { dbg = []; }
| Scoped_location.Loc_unknown -> { dbg = []; assume_zero_alloc = false; }
| Scoped_location.Loc_known {scopes; loc} ->
assert (not (Location.is_none loc));
{ dbg = [item_from_location ~scopes loc]; }
let assume_zero_alloc = Scoped_location.get_assume_zero_alloc ~scopes in
{ dbg = [item_from_location ~scopes loc]; assume_zero_alloc; }

let to_location { dbg } =
let to_location { dbg; assume_zero_alloc=_ } =
match dbg with
| [] -> Location.none
| d :: _ ->
Expand All @@ -214,41 +285,17 @@ let to_location { dbg } =
} in
{ loc_ghost = false; loc_start; loc_end; }

let inline { dbg = dbg1; } { dbg = dbg2; } =
{ dbg = 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 { dbg = dbg1; } { dbg = 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 = Int.compare d1.dinfo_line d2.dinfo_line in
if c <> 0 then c else
let c = Int.compare d1.dinfo_char_end d2.dinfo_char_end in
if c <> 0 then c else
let c = Int.compare d1.dinfo_char_start d2.dinfo_char_start in
if c <> 0 then c else
let c = Int.compare d1.dinfo_start_bol d2.dinfo_start_bol in
if c <> 0 then c else
let c = Int.compare d1.dinfo_end_bol d2.dinfo_end_bol in
if c <> 0 then c else
let c = Int.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 inline { dbg = dbg1; assume_zero_alloc = a1; }
{ dbg = dbg2; assume_zero_alloc = a2; } =
{ dbg = dbg1 @ dbg2; assume_zero_alloc = a1 || a2; }

let is_none { dbg; assume_zero_alloc } =
(not assume_zero_alloc) && Dbg.is_none dbg

let hash { dbg; } =
List.fold_left (fun hash item -> Hashtbl.hash (hash, item)) 0 dbg
let compare { dbg = dbg1; assume_zero_alloc = a1; }
{ dbg = dbg2; assume_zero_alloc = a2; } =
let res = Dbg.compare dbg1 dbg2 in
if res <> 0 then res else Bool.compare a1 a2

let rec print_compact ppf t =
let print_item item =
Expand All @@ -269,9 +316,17 @@ let rec print_compact ppf t =

let print_compact ppf { dbg; } = print_compact ppf dbg

let to_list { dbg; } = dbg
let merge ~into:{ dbg = dbg1; assume_zero_alloc = a1; }
{ dbg = dbg2; assume_zero_alloc = a2 } =
(* Keep the first [dbg] info to match existing behavior.
When assume_zero_alloc is only on one of the inputs but not both, keep [dbg]
from the other.
*)
{ dbg = if a1 && not a2 then dbg2 else dbg1;
assume_zero_alloc = a1 && a2
}

let assume_zero_alloc t = t.assume_zero_alloc

let length { dbg; } = List.length dbg
let get_dbg t = t.dbg

let merge ~into:{ dbg = dbg1 } { dbg = _dbg2; } =
{ dbg = dbg1 }
Loading

0 comments on commit b9cf106

Please sign in to comment.