Skip to content

Commit

Permalink
Make backtraces aware of inlining (#247)
Browse files Browse the repository at this point in the history
  • Loading branch information
@let-def @mshinwell
let-def authored and mshinwell committed May 25, 2016
1 parent b02d9ae commit 28dc832
Show file tree
Hide file tree
Showing 24 changed files with 613 additions and 210 deletions.
138 changes: 77 additions & 61 deletions asmcomp/closure.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -508,17 +508,24 @@ let find_action idxs acts tag =
(* Can this happen? *)
None

let subst_debuginfo loc dbg =
if !Clflags.debug then
Debuginfo.inline loc dbg
else
dbg

let rec substitute fpc sb ulam =
let rec substitute loc fpc sb ulam =
match ulam with
Uvar v ->
begin try Tbl.find v sb with Not_found -> ulam end
| Uconst _ -> ulam
| Udirect_apply(lbl, args, dbg) ->
Udirect_apply(lbl, List.map (substitute fpc sb) args, dbg)
let dbg = subst_debuginfo loc dbg in
Udirect_apply(lbl, List.map (substitute loc fpc sb) args, dbg)
| Ugeneric_apply(fn, args, dbg) ->
Ugeneric_apply(substitute fpc sb fn,
List.map (substitute fpc sb) args, dbg)
let dbg = subst_debuginfo loc dbg in
Ugeneric_apply(substitute loc fpc sb fn,
List.map (substitute loc fpc sb) args, dbg)
| Uclosure(defs, env) ->
(* Question: should we rename function labels as well? Otherwise,
there is a risk that function labels are not globally unique.
Expand All @@ -528,12 +535,12 @@ let rec substitute fpc sb ulam =
- When we substitute offsets for idents bound by let rec
in [close], case [Lletrec], we discard the original
let rec body and use only the substituted term. *)
Uclosure(defs, List.map (substitute fpc sb) env)
| Uoffset(u, ofs) -> Uoffset(substitute fpc sb u, ofs)
Uclosure(defs, List.map (substitute loc fpc sb) env)
| Uoffset(u, ofs) -> Uoffset(substitute loc fpc sb u, ofs)
| Ulet(str, kind, id, u1, u2) ->
let id' = Ident.rename id in
Ulet(str, kind, id', substitute fpc sb u1,
substitute fpc (Tbl.add id (Uvar id') sb) u2)
Ulet(str, kind, id', substitute loc fpc sb u1,
substitute loc fpc (Tbl.add id (Uvar id') sb) u2)
| Uletrec(bindings, body) ->
let bindings1 =
List.map (fun (id, rhs) -> (id, Ident.rename id, rhs)) bindings in
Expand All @@ -543,17 +550,17 @@ let rec substitute fpc sb ulam =
bindings1 sb in
Uletrec(
List.map
(fun (_id, id', rhs) -> (id', substitute fpc sb' rhs))
(fun (_id, id', rhs) -> (id', substitute loc fpc sb' rhs))
bindings1,
substitute fpc sb' body)
substitute loc fpc sb' body)
| Uprim(p, args, dbg) ->
let sargs =
List.map (substitute fpc sb) args in
let sargs = List.map (substitute loc fpc sb) args in
let dbg = subst_debuginfo loc dbg in
let (res, _) =
simplif_prim fpc p (sargs, List.map approx_ulam sargs) dbg in
res
| Uswitch(arg, sw) ->
let sarg = substitute fpc sb arg in
let sarg = substitute loc fpc sb arg in
let action =
(* Unfortunately, we cannot easily deal with the
case of a constructed block (makeblock) bound to a local
Expand All @@ -569,62 +576,63 @@ let rec substitute fpc sb ulam =
| _ -> None
in
begin match action with
| Some u -> substitute fpc sb u
| Some u -> substitute loc fpc sb u
| None ->
Uswitch(sarg,
{ sw with
us_actions_consts =
Array.map (substitute fpc sb) sw.us_actions_consts;
Array.map (substitute loc fpc sb) sw.us_actions_consts;
us_actions_blocks =
Array.map (substitute fpc sb) sw.us_actions_blocks;
Array.map (substitute loc fpc sb) sw.us_actions_blocks;
})
end
| Ustringswitch(arg,sw,d) ->
Ustringswitch
(substitute fpc sb arg,
List.map (fun (s,act) -> s,substitute fpc sb act) sw,
Misc.may_map (substitute fpc sb) d)
(substitute loc fpc sb arg,
List.map (fun (s,act) -> s,substitute loc fpc sb act) sw,
Misc.may_map (substitute loc fpc sb) d)
| Ustaticfail (nfail, args) ->
Ustaticfail (nfail, List.map (substitute fpc sb) args)
Ustaticfail (nfail, List.map (substitute loc fpc sb) args)
| Ucatch(nfail, ids, u1, u2) ->
let ids' = List.map Ident.rename ids in
let sb' =
List.fold_right2
(fun id id' s -> Tbl.add id (Uvar id') s)
ids ids' sb
in
Ucatch(nfail, ids', substitute fpc sb u1, substitute fpc sb' u2)
Ucatch(nfail, ids', substitute loc fpc sb u1, substitute loc fpc sb' u2)
| Utrywith(u1, id, u2) ->
let id' = Ident.rename id in
Utrywith(substitute fpc sb u1, id',
substitute fpc (Tbl.add id (Uvar id') sb) u2)
Utrywith(substitute loc fpc sb u1, id',
substitute loc fpc (Tbl.add id (Uvar id') sb) u2)
| Uifthenelse(u1, u2, u3) ->
begin match substitute fpc sb u1 with
begin match substitute loc fpc sb u1 with
Uconst (Uconst_ptr n) ->
if n <> 0 then substitute fpc sb u2 else substitute fpc sb u3
if n <> 0 then substitute loc fpc sb u2 else substitute loc fpc sb u3
| Uprim(Pmakeblock _, _, _) ->
substitute fpc sb u2
substitute loc fpc sb u2
| su1 ->
Uifthenelse(su1, substitute fpc sb u2, substitute fpc sb u3)
Uifthenelse(su1, substitute loc fpc sb u2, substitute loc fpc sb u3)
end
| Usequence(u1, u2) ->
Usequence(substitute fpc sb u1, substitute fpc sb u2)
Usequence(substitute loc fpc sb u1, substitute loc fpc sb u2)
| Uwhile(u1, u2) ->
Uwhile(substitute fpc sb u1, substitute fpc sb u2)
Uwhile(substitute loc fpc sb u1, substitute loc fpc sb u2)
| Ufor(id, u1, u2, dir, u3) ->
let id' = Ident.rename id in
Ufor(id', substitute fpc sb u1, substitute fpc sb u2, dir,
substitute fpc (Tbl.add id (Uvar id') sb) u3)
Ufor(id', substitute loc fpc sb u1, substitute loc fpc sb u2, dir,
substitute loc fpc (Tbl.add id (Uvar id') sb) u3)
| Uassign(id, u) ->
let id' =
try
match Tbl.find id sb with Uvar i -> i | _ -> assert false
with Not_found ->
id in
Uassign(id', substitute fpc sb u)
Uassign(id', substitute loc fpc sb u)
| Usend(k, u1, u2, ul, dbg) ->
Usend(k, substitute fpc sb u1, substitute fpc sb u2,
List.map (substitute fpc sb) ul, dbg)
let dbg = subst_debuginfo loc dbg in
Usend(k, substitute loc fpc sb u1, substitute loc fpc sb u2,
List.map (substitute loc fpc sb) ul, dbg)
| Uunreachable ->
Uunreachable

Expand All @@ -638,12 +646,12 @@ let no_effects = function
| Uclosure _ -> true
| u -> is_simple_argument u

let rec bind_params_rec fpc subst params args body =
let rec bind_params_rec loc fpc subst params args body =
match (params, args) with
([], []) -> substitute fpc subst body
([], []) -> substitute loc fpc subst body
| (p1 :: pl, a1 :: al) ->
if is_simple_argument a1 then
bind_params_rec fpc (Tbl.add p1 a1 subst) pl al body
bind_params_rec loc fpc (Tbl.add p1 a1 subst) pl al body
else begin
let p1' = Ident.rename p1 in
let u1, u2 =
Expand All @@ -654,17 +662,17 @@ let rec bind_params_rec fpc subst params args body =
a1, Uvar p1'
in
let body' =
bind_params_rec fpc (Tbl.add p1 u2 subst) pl al body in
bind_params_rec loc fpc (Tbl.add p1 u2 subst) pl al body in
if occurs_var p1 body then Ulet(Immutable, Pgenval, p1', u1, body')
else if no_effects a1 then body'
else Usequence(a1, body')
end
| (_, _) -> assert false

let bind_params fpc params args body =
let bind_params loc fpc params args body =
(* Reverse parameters and arguments to preserve right-to-left
evaluation order (PR#2910). *)
bind_params_rec fpc Tbl.empty (List.rev params) (List.rev args) body
bind_params_rec loc fpc Tbl.empty (List.rev params) (List.rev args) body

(* Check if a lambda term is ``pure'',
that is without side-effects *and* not containing function definitions *)
Expand Down Expand Up @@ -695,7 +703,7 @@ let direct_apply fundesc funct ufunct uargs ~loc ~attribute =
"Function information unavailable";
Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none)
| Some(params, body), _ ->
bind_params fundesc.fun_float_const_prop params app_args body
bind_params loc fundesc.fun_float_const_prop params app_args body
in
(* If ufunct can contain side-effects or function definitions,
we must make sure that it is evaluated exactly once.
Expand Down Expand Up @@ -750,23 +758,28 @@ let excessive_function_nesting_depth = 5
(* Decorate clambda term with debug information *)

let rec add_debug_info ev u =
let put_dinfo dinfo ev =
if Debuginfo.is_none dinfo then
Debuginfo.from_call ev
else dinfo
in
match ev.lev_kind with
| Lev_after _ ->
begin match u with
| Udirect_apply(lbl, args, _dinfo) ->
Udirect_apply(lbl, args, Debuginfo.from_call ev)
| Ugeneric_apply(Udirect_apply(lbl, args1, _dinfo1),
args2, _dinfo2) ->
Ugeneric_apply(Udirect_apply(lbl, args1, Debuginfo.from_call ev),
args2, Debuginfo.from_call ev)
| Ugeneric_apply(fn, args, _dinfo) ->
Ugeneric_apply(fn, args, Debuginfo.from_call ev)
| Uprim(Praise k, args, _dinfo) ->
Uprim(Praise k, args, Debuginfo.from_call ev)
| Uprim(p, args, _dinfo) ->
Uprim(p, args, Debuginfo.from_call ev)
| Usend(kind, u1, u2, args, _dinfo) ->
Usend(kind, u1, u2, args, Debuginfo.from_call ev)
| Udirect_apply(lbl, args, dinfo) ->
Udirect_apply(lbl, args, put_dinfo dinfo ev)
| Ugeneric_apply(Udirect_apply(lbl, args1, dinfo1),
args2, dinfo2) ->
Ugeneric_apply(Udirect_apply(lbl, args1, put_dinfo dinfo1 ev),
args2, put_dinfo dinfo2 ev)
| Ugeneric_apply(fn, args, dinfo) ->
Ugeneric_apply(fn, args, put_dinfo dinfo ev)
| Uprim(Praise k, args, dinfo) ->
Uprim(Praise k, args, put_dinfo dinfo ev)
| Uprim(p, args, dinfo) ->
Uprim(p, args, put_dinfo dinfo ev)
| Usend(kind, u1, u2, args, dinfo) ->
Usend(kind, u1, u2, args, put_dinfo dinfo ev)
| Usequence(u1, u2) ->
Usequence(u1, add_debug_info ev u2)
| _ -> u
Expand Down Expand Up @@ -836,11 +849,13 @@ let rec close fenv cenv = function
((ufunct, Value_closure(fundesc, approx_res)),
[Uprim(Pmakeblock _, uargs, _)])
when List.length uargs = - fundesc.fun_arity ->
let app = direct_apply ~loc ~attribute fundesc funct ufunct uargs in
let app =
direct_apply ~loc ~attribute fundesc funct ufunct uargs in
(app, strengthen_approx app approx_res)
| ((ufunct, Value_closure(fundesc, approx_res)), uargs)
when nargs = fundesc.fun_arity ->
let app = direct_apply ~loc ~attribute fundesc funct ufunct uargs in
let app =
direct_apply ~loc ~attribute fundesc funct ufunct uargs in
(app, strengthen_approx app approx_res)

| ((_ufunct, Value_closure(fundesc, _approx_res)), uargs)
Expand Down Expand Up @@ -881,8 +896,9 @@ let rec close fenv cenv = function
when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity ->
let (first_args, rem_args) = split_list fundesc.fun_arity uargs in
warning_if_forced_inline ~loc ~attribute "Over-application";
(Ugeneric_apply(direct_apply ~loc ~attribute fundesc funct ufunct
first_args, rem_args, Debuginfo.none),
(Ugeneric_apply(direct_apply ~loc ~attribute
fundesc funct ufunct first_args,
rem_args, Debuginfo.none),
Value_unknown)
| ((ufunct, _), uargs) ->
warning_if_forced_inline ~loc ~attribute "Unknown function";
Expand Down Expand Up @@ -924,8 +940,8 @@ let rec close fenv cenv = function
(fun (id, pos, _approx) sb ->
Tbl.add id (Uoffset(Uvar clos_ident, pos)) sb)
infos Tbl.empty in
(Ulet(Immutable, Pgenval,
clos_ident, clos, substitute !Clflags.float_const_prop sb ubody),
(Ulet(Immutable, Pgenval, clos_ident, clos,
substitute Location.none !Clflags.float_const_prop sb ubody),
approx)
end else begin
(* General case: recursive definition of values *)
Expand Down
70 changes: 52 additions & 18 deletions asmcomp/emitaux.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -133,7 +133,23 @@ let emit_frames a =
with Not_found ->
let lbl = Linearize.new_label () in
Hashtbl.add filenames name lbl;
lbl in
lbl
in
let debuginfos = Hashtbl.create 7 in
let rec label_debuginfos key =
try fst (Hashtbl.find debuginfos key)
with Not_found ->
let lbl = Linearize.new_label () in
let next = match key with
| _d, (d' :: ds') -> Some (label_debuginfos (d',ds'))
| _d, [] -> None
in
Hashtbl.add debuginfos key (lbl, next);
lbl
in
let emit_debuginfo_label d =
a.efa_label (label_debuginfos (Debuginfo.unroll_inline_chain d))
in
let emit_frame fd =
a.efa_label fd.fd_lbl;
a.efa_16 (if Debuginfo.is_none fd.fd_debuginfo
Expand All @@ -142,28 +158,45 @@ let emit_frames a =
a.efa_16 (List.length fd.fd_live_offset);
List.iter a.efa_16 fd.fd_live_offset;
a.efa_align Arch.size_addr;
if not (Debuginfo.is_none fd.fd_debuginfo) then begin
let d = fd.fd_debuginfo in
let line = min 0xFFFFF d.dinfo_line
and char_start = min 0xFF d.dinfo_char_start
and char_end = min 0x3FF d.dinfo_char_end
and kind = match d.dinfo_kind with Dinfo_call -> 0 | Dinfo_raise -> 1 in
let info =
Int64.add (Int64.shift_left (Int64.of_int line) 44) (
Int64.add (Int64.shift_left (Int64.of_int char_start) 36) (
Int64.add (Int64.shift_left (Int64.of_int char_end) 26)
(Int64.of_int kind))) in
a.efa_label_rel
(label_filename d.dinfo_file)
(Int64.to_int32 info);
a.efa_32 (Int64.to_int32 (Int64.shift_right info 32))
end in
if not (Debuginfo.is_none fd.fd_debuginfo) then
emit_debuginfo_label fd.fd_debuginfo
in
let emit_filename name lbl =
a.efa_def_label lbl;
a.efa_string name;
a.efa_align Arch.size_addr in
a.efa_align Arch.size_addr
in
let pack_info d =
let line = min 0xFFFFF d.dinfo_line
and char_start = min 0xFF d.dinfo_char_start
and char_end = min 0x3FF d.dinfo_char_end
and kind = match d.dinfo_kind with
| Dinfo_call -> 0
| Dinfo_raise -> 1
| Dinfo_inline _ ->
assert false (* Should disappear after unrolling inline chain *)
in
Int64.(add (shift_left (of_int line) 44)
(add (shift_left (of_int char_start) 36)
(add (shift_left (of_int char_end) 26)
(of_int kind))))
in
let emit_debuginfo (d,_) (lbl,next) =
a.efa_align Arch.size_addr;
a.efa_def_label lbl;
let info = pack_info d in
a.efa_label_rel
(label_filename d.dinfo_file)
(Int64.to_int32 info);
a.efa_32 (Int64.to_int32 (Int64.shift_right info 32));
begin match next with
| Some next -> a.efa_label next
| None -> a.efa_word 0
end
in
a.efa_word (List.length !frame_descriptors);
List.iter emit_frame !frame_descriptors;
Hashtbl.iter emit_debuginfo debuginfos;
Hashtbl.iter emit_filename filenames;
frame_descriptors := []

Expand Down Expand Up @@ -224,6 +257,7 @@ let reset_debug_info () =
(* We only diplay .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.unroll_inline_chain dbg in
if is_cfi_enabled () &&
(!Clflags.debug || Config.with_frame_pointers)
&& dbg.Debuginfo.dinfo_line > 0 (* PR#6243 *)
Expand Down

0 comments on commit 28dc832

Please sign in to comment.