Anonymous | Login | Signup for a new account | 2019-02-23 07:59 CET | ![]() |
Main | My View | View Issues | Change Log | Roadmap |
View Issue Details [ Jump to Notes ] | [ Issue History ] [ Print ] | |||||||
ID | Project | Category | View Status | Date Submitted | Last Update | |||
0004888 | OCaml | ~DO NOT USE (was: OCaml general) | public | 2009-10-05 13:44 | 2013-08-31 12:48 | |||
Reporter | apoirot | |||||||
Assigned To | ||||||||
Priority | normal | Severity | tweak | Reproducibility | always | |||
Status | closed | Resolution | fixed | |||||
Platform | OS | OS Version | ||||||
Product Version | 3.11.1 | |||||||
Target Version | Fixed in Version | 3.13.0+dev | ||||||
Summary | 0004888: Improve again x86/ELF for GNU debugging tools | |||||||
Description | A lot of debugging tools are based on two ELF declarations that ocaml compiler does not handle : .file and .loc. By enabling these two little things you can : - set breakpoints on ocaml function with gdb in native code! - see functions executions counts in gprof, - generate annoted ocaml source, with, for each function details of sub functions called (with valgrind/callgrind). I've done a blog post about all these possibilities (in french: http://blog.techno-barje.fr/post/2008/11/09/Ocaml-native-code-debugging [^]) I've already done a patch which modify all compilation chain in order to add a new fun_dbg:Debuginfo.t on all fun_decl types. This attribute is filled in closure.ml:close_functions and then is just copied in each compilation step, with some new functions arguments in order to pass this new information. -> patch-file-and-loc-v1-cvs-2008-11-11.patch This is not the cleanest and best solution, but that's working for all function calls. A better solution is to set the dbg:Debuginfo.t attribute in instruction type, and that for all instructions ... but I was really unable to do that! Nor was I able to set this attribute just for the first instruction of all function... But with this approach, we would be able to set breakpoint on any ocaml source code line! (instead of just function call with my current work) Keep me in touch if you decide to get this solution or if you know any other way for adding these two declarations. | |||||||
Tags | No tags attached. | |||||||
Attached Files | ![]() diff -r 8c3eb45b53c2 asmcomp/clambda.ml --- a/asmcomp/clambda.ml Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/clambda.ml Wed Nov 12 00:25:13 2008 +0100 @@ -25,7 +25,7 @@ type ulambda = | Uconst of structured_constant | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t - | Uclosure of (function_label * int * Ident.t list * ulambda) list + | Uclosure of (function_label * int * Ident.t list * Debuginfo.t * ulambda) list * ulambda list | Uoffset of ulambda * int | Ulet of Ident.t * ulambda * ulambda @@ -52,6 +52,7 @@ and ulambda_switch = type function_description = { fun_label: function_label; (* Label of direct entry point *) + fun_dbg: Debuginfo.t; (* Debug info : source code position *) fun_arity: int; (* Number of arguments *) mutable fun_closed: bool; (* True if environment not used *) mutable fun_inline: (Ident.t list * ulambda) option } diff -r 8c3eb45b53c2 asmcomp/clambda.mli --- a/asmcomp/clambda.mli Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/clambda.mli Wed Nov 12 00:25:13 2008 +0100 @@ -25,7 +25,7 @@ type ulambda = | Uconst of structured_constant | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t - | Uclosure of (function_label * int * Ident.t list * ulambda) list + | Uclosure of (function_label * int * Ident.t list * Debuginfo.t * ulambda) list * ulambda list | Uoffset of ulambda * int | Ulet of Ident.t * ulambda * ulambda @@ -52,6 +52,7 @@ and ulambda_switch = type function_description = { fun_label: function_label; (* Label of direct entry point *) + fun_dbg : Debuginfo.t; (* Debug info : file, line ,... *) fun_arity: int; (* Number of arguments *) mutable fun_closed: bool; (* True if environment not used *) mutable fun_inline: (Ident.t list * ulambda) option } diff -r 8c3eb45b53c2 asmcomp/closure.ml --- a/asmcomp/closure.ml Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/closure.ml Wed Nov 12 00:25:13 2008 +0100 @@ -518,7 +518,7 @@ let rec close fenv cenv = function let (uobj, _) = close fenv cenv obj in (Usend(kind, umet, uobj, close_list fenv cenv args, Debuginfo.none), Value_unknown) - | Llet(str, id, lam, body) -> + | Llet(str, id, lam, body) -> let (ulam, alam) = close_named fenv cenv id lam in begin match (str, alam) with (Variable, _) -> @@ -685,8 +685,15 @@ and close_functions fenv cenv fun_defs = (id, Lfunction(kind, params, body)) -> let label = Compilenv.make_symbol (Some (Ident.unique_name id)) in let arity = List.length params in + let dbg = match body with + Levent(_,ev) -> + Debuginfo.from_call ev + | _ -> + Debuginfo.none + in let fundesc = {fun_label = label; + fun_dbg = dbg; fun_arity = (if kind = Tupled then -arity else arity); fun_closed = initially_closed; fun_inline = None } in @@ -725,7 +732,7 @@ and close_functions fenv cenv fun_defs = let (ubody, approx) = close fenv_rec cenv_body body in if !useless_env && occurs_var env_param ubody then useless_env := false; let fun_params = if !useless_env then params else params @ [env_param] in - ((fundesc.fun_label, fundesc.fun_arity, fun_params, ubody), + ((fundesc.fun_label, fundesc.fun_arity, fun_params, fundesc.fun_dbg, ubody), (id, env_pos, Value_closure(fundesc, approx))) in (* Translate all function definitions. *) let clos_info_list = @@ -755,7 +762,7 @@ and close_functions fenv cenv fun_defs = and close_one_function fenv cenv id funct = match close_functions fenv cenv [id, funct] with - ((Uclosure([_, _, params, body], _) as clos), + ((Uclosure([_, _, params, dbg, body], _) as clos), [_, _, (Value_closure(fundesc, _) as approx)]) -> (* See if the function can be inlined *) if lambda_smaller body (!Clflags.inline_threshold + List.length params) diff -r 8c3eb45b53c2 asmcomp/cmm.ml --- a/asmcomp/cmm.ml Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/cmm.ml Wed Nov 12 00:25:13 2008 +0100 @@ -107,6 +107,7 @@ type fundecl = type fundecl = { fun_name: string; fun_args: (Ident.t * machtype) list; + fun_dbg: Debuginfo.t; fun_body: expression; fun_fast: bool } diff -r 8c3eb45b53c2 asmcomp/cmm.mli --- a/asmcomp/cmm.mli Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/cmm.mli Wed Nov 12 00:25:13 2008 +0100 @@ -93,6 +93,7 @@ type fundecl = type fundecl = { fun_name: string; fun_args: (Ident.t * machtype) list; + fun_dbg : Debuginfo.t; fun_body: expression; fun_fast: bool } diff -r 8c3eb45b53c2 asmcomp/cmmgen.ml --- a/asmcomp/cmmgen.ml Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/cmmgen.ml Wed Nov 12 00:25:13 2008 +0100 @@ -369,7 +369,7 @@ let fundecls_size fundecls = let fundecls_size fundecls = let sz = ref (-1) in List.iter - (fun (label, arity, params, body) -> + (fun (label, arity, params, dbg, body) -> sz := !sz + 1 + (if arity = 1 then 2 else 3)) fundecls; !sz @@ -445,7 +445,7 @@ let transl_constant = function (* Translate constant closures *) let constant_closures = - ref ([] : (string * (string * int * Ident.t list * ulambda) list) list) + ref ([] : (string * (string * int * Ident.t list * Debuginfo.t * ulambda) list) list) (* Boxed integers *) @@ -784,7 +784,7 @@ let subst_boxed_number unbox_fn boxed_id (* Translate an expression *) -let functions = (Queue.create() : (string * Ident.t list * ulambda) Queue.t) +let functions = (Queue.create() : (string * Ident.t list * Debuginfo.t * ulambda) Queue.t) let rec transl = function Uvar id -> @@ -795,8 +795,8 @@ let rec transl = function let lbl = new_const_symbol() in constant_closures := (lbl, fundecls) :: !constant_closures; List.iter - (fun (label, arity, params, body) -> - Queue.add (label, params, body) functions) + (fun (label, arity, params, dbg, body) -> + Queue.add (label, params, dbg, body) functions) fundecls; Cconst_symbol lbl | Uclosure(fundecls, clos_vars) -> @@ -805,8 +805,8 @@ let rec transl = function let rec transl_fundecls pos = function [] -> List.map transl clos_vars - | (label, arity, params, body) :: rem -> - Queue.add (label, params, body) functions; + | (label, arity, params, dbg, body) :: rem -> + Queue.add (label, params, dbg, body) functions; let header = if pos = 0 then alloc_closure_header block_size @@ -1514,9 +1514,10 @@ and transl_letrec bindings cont = (* Translate a function definition *) -let transl_function lbl params body = +let transl_function lbl params dbg body = Cfunction {fun_name = lbl; fun_args = List.map (fun id -> (id, typ_addr)) params; + fun_dbg = dbg; fun_body = transl body; fun_fast = !Clflags.optimize_for_speed} @@ -1530,12 +1531,12 @@ module StringSet = let rec transl_all_functions already_translated cont = try - let (lbl, params, body) = Queue.take functions in + let (lbl, params, dbg, body) = Queue.take functions in if StringSet.mem lbl already_translated then transl_all_functions already_translated cont else begin transl_all_functions (StringSet.add lbl already_translated) - (transl_function lbl params body :: cont) + (transl_function lbl params dbg body :: cont) end with Queue.Empty -> cont @@ -1667,10 +1668,10 @@ let emit_constant_closure symb fundecls let emit_constant_closure symb fundecls cont = match fundecls with [] -> assert false - | (label, arity, params, body) :: remainder -> + | (label, arity, params, dbg, body) :: remainder -> let rec emit_others pos = function [] -> cont - | (label, arity, params, body) :: rem -> + | (label, arity, params, dbg, body) :: rem -> if arity = 1 then Cint(infix_header pos) :: Csymbol_address label :: @@ -1717,6 +1718,7 @@ let compunit size ulam = let init_code = transl ulam in let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry"); fun_args = []; + fun_dbg = Debuginfo.none; fun_body = init_code; fun_fast = false}] in let c2 = transl_all_functions StringSet.empty c1 in let c3 = emit_all_constants c2 in @@ -1845,6 +1847,7 @@ let send_function arity = Cfunction {fun_name = "caml_send" ^ string_of_int arity; fun_args = fun_args; + fun_dbg = Debuginfo.none; fun_body = body; fun_fast = true} @@ -1854,6 +1857,7 @@ let apply_function arity = Cfunction {fun_name = "caml_apply" ^ string_of_int arity; fun_args = List.map (fun id -> (id, typ_addr)) all_args; + fun_dbg = Debuginfo.none; fun_body = body; fun_fast = true} @@ -1871,6 +1875,7 @@ let tuplify_function arity = Cfunction {fun_name = "caml_tuplify" ^ string_of_int arity; fun_args = [arg, typ_addr; clos, typ_addr]; + fun_dbg = Debuginfo.none; fun_body = Cop(Capply(typ_addr, Debuginfo.none), get_field (Cvar clos) 2 :: access_components 0 @ [Cvar clos]); @@ -1909,6 +1914,7 @@ let final_curry_function arity = {fun_name = "caml_curry" ^ string_of_int arity ^ "_" ^ string_of_int (arity-1); fun_args = [last_arg, typ_addr; last_clos, typ_addr]; + fun_dbg = Debuginfo.none; fun_body = curry_fun [] last_clos (arity-1); fun_fast = true} @@ -1922,6 +1928,7 @@ let rec intermediate_curry_functions ari Cfunction {fun_name = name2; fun_args = [arg, typ_addr; clos, typ_addr]; + fun_dbg = Debuginfo.none; fun_body = Cop(Calloc, [alloc_closure_header 4; Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)); @@ -1983,6 +1990,7 @@ let entry_point namelist = namelist (Cconst_int 1) in Cfunction {fun_name = "caml_program"; fun_args = []; + fun_dbg = Debuginfo.none; fun_body = body; fun_fast = false} diff -r 8c3eb45b53c2 asmcomp/debuginfo.ml --- a/asmcomp/debuginfo.ml Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/debuginfo.ml Wed Nov 12 00:25:13 2008 +0100 @@ -38,7 +38,6 @@ let to_string d = d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end let from_location kind loc = - if loc.loc_ghost then none else { dinfo_kind = kind; dinfo_file = loc.loc_start.pos_fname; dinfo_line = loc.loc_start.pos_lnum; diff -r 8c3eb45b53c2 asmcomp/i386/emit.mlp --- a/asmcomp/i386/emit.mlp Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/i386/emit.mlp Wed Nov 12 00:25:13 2008 +0100 @@ -877,6 +877,9 @@ let emit_profile () = (* Emission of a function declaration *) +open Debuginfo +let file_counter = ref 1 + let fundecl fundecl = function_name := fundecl.fun_name; fastcode_flag := fundecl.fun_fast; @@ -890,6 +893,18 @@ let fundecl fundecl = emit_align 16; ` .globl {emit_symbol fundecl.fun_name}\n`; `{emit_symbol fundecl.fun_name}:\n`; + if !Clflags.debug then begin + let dbg = fundecl.fun_dbg in + let file_name = dbg.dinfo_file + and file_num=(!file_counter) + and file_line=dbg.dinfo_line + in + if file_name<>"" then begin + `\t.file {emit_int file_num} \"{emit_string file_name}\"\n`; + `\t.loc {emit_int file_num} {emit_int file_line}\n`; + incr file_counter; + end; + end; if !Clflags.gprofile then emit_profile(); let n = frame_size() - 4 in if n > 0 then diff -r 8c3eb45b53c2 asmcomp/linearize.ml --- a/asmcomp/linearize.ml Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/linearize.ml Wed Nov 12 00:25:13 2008 +0100 @@ -53,6 +53,7 @@ let has_fallthrough = function type fundecl = { fun_name: string; + fun_dbg : Debuginfo.t; fun_body: instruction; fun_fast: bool } @@ -263,5 +264,6 @@ let rec linear i n = let fundecl f = { fun_name = f.Mach.fun_name; + fun_dbg = f.Mach.fun_dbg; fun_body = linear f.Mach.fun_body end_instr; fun_fast = f.Mach.fun_fast } diff -r 8c3eb45b53c2 asmcomp/linearize.mli --- a/asmcomp/linearize.mli Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/linearize.mli Wed Nov 12 00:25:13 2008 +0100 @@ -48,6 +48,7 @@ val invert_test: Mach.test -> Mach.test type fundecl = { fun_name: string; + fun_dbg : Debuginfo.t; fun_body: instruction; fun_fast: bool } diff -r 8c3eb45b53c2 asmcomp/mach.ml --- a/asmcomp/mach.ml Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/mach.ml Wed Nov 12 00:25:13 2008 +0100 @@ -78,6 +78,7 @@ type fundecl = type fundecl = { fun_name: string; fun_args: Reg.t array; + fun_dbg : Debuginfo.t; fun_body: instruction; fun_fast: bool } diff -r 8c3eb45b53c2 asmcomp/mach.mli --- a/asmcomp/mach.mli Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/mach.mli Wed Nov 12 00:25:13 2008 +0100 @@ -78,6 +78,7 @@ type fundecl = type fundecl = { fun_name: string; fun_args: Reg.t array; + fun_dbg : Debuginfo.t; fun_body: instruction; fun_fast: bool } diff -r 8c3eb45b53c2 asmcomp/printcmm.ml --- a/asmcomp/printcmm.ml Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/printcmm.ml Wed Nov 12 00:25:13 2008 +0100 @@ -176,8 +176,13 @@ let fundecl ppf f = if !first then first := false else fprintf ppf "@ "; fprintf ppf "%a: %a" Ident.print id machtype ty) cases in - fprintf ppf "@[<1>(function %s@;<1 4>@[<1>(%a)@]@ @[%a@])@]@." - f.fun_name print_cases f.fun_args sequence f.fun_body + let dbg = + if f.fun_dbg = Debuginfo.none + then "no dbg" + else Debuginfo.to_string f.fun_dbg + in + fprintf ppf "@[<1>(function %s %s@;<1 4>@[<1>(%a)@]@ @[%a@])@]@." + f.fun_name dbg print_cases f.fun_args sequence f.fun_body let data_item ppf = function | Cdefine_symbol s -> fprintf ppf "\"%s\":" s diff -r 8c3eb45b53c2 asmcomp/printlinear.ml --- a/asmcomp/printlinear.ml Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/printlinear.ml Wed Nov 12 00:25:13 2008 +0100 @@ -74,4 +74,9 @@ let rec all_instr ppf i = | _ -> fprintf ppf "%a@,%a" instr i all_instr i.next let fundecl ppf f = - fprintf ppf "@[<v 2>%s:@,%a@]" f.fun_name all_instr f.fun_body + let dbg = + if f.fun_dbg = Debuginfo.none + then "no dbg" + else Debuginfo.to_string f.fun_dbg + in + fprintf ppf "@[<v 2>%s:%s@,%a@]" f.fun_name dbg all_instr f.fun_body diff -r 8c3eb45b53c2 asmcomp/printmach.ml --- a/asmcomp/printmach.ml Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/printmach.ml Wed Nov 12 00:25:13 2008 +0100 @@ -190,8 +190,13 @@ let rec instr ppf i = end let fundecl ppf f = - fprintf ppf "@[<v 2>%s(%a)@,%a@]" - f.fun_name regs f.fun_args instr f.fun_body + let dbg = + if f.fun_dbg = Debuginfo.none + then "no dbg" + else Debuginfo.to_string f.fun_dbg + in + fprintf ppf "@[<v 2>%s %s (%a)@,%a@]" + f.fun_name dbg regs f.fun_args instr f.fun_body let phase msg ppf f = fprintf ppf "*** %s@.%a@." msg fundecl f diff -r 8c3eb45b53c2 asmcomp/reloadgen.ml --- a/asmcomp/reloadgen.ml Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/reloadgen.ml Wed Nov 12 00:25:13 2008 +0100 @@ -134,6 +134,7 @@ method fundecl f = redo_regalloc <- false; let new_body = self#reload f.fun_body in ({fun_name = f.fun_name; fun_args = f.fun_args; + fun_dbg = f.fun_dbg; fun_body = new_body; fun_fast = f.fun_fast}, redo_regalloc) diff -r 8c3eb45b53c2 asmcomp/schedgen.ml --- a/asmcomp/schedgen.ml Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/schedgen.ml Wed Nov 12 00:25:13 2008 +0100 @@ -348,6 +348,7 @@ method schedule_fundecl f = let new_body = schedule f.fun_body in clear_code_dag(); { fun_name = f.fun_name; + fun_dbg = f.fun_dbg; fun_body = new_body; fun_fast = f.fun_fast } end else diff -r 8c3eb45b53c2 asmcomp/selectgen.ml --- a/asmcomp/selectgen.ml Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/selectgen.ml Wed Nov 12 00:25:13 2008 +0100 @@ -820,6 +820,7 @@ method emit_fundecl f = self#emit_tail env f.Cmm.fun_body; { fun_name = f.Cmm.fun_name; fun_args = loc_arg; + fun_dbg = f.Cmm.fun_dbg; fun_body = self#extract; fun_fast = f.Cmm.fun_fast } diff -r 8c3eb45b53c2 asmcomp/spill.ml --- a/asmcomp/spill.ml Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/spill.ml Wed Nov 12 00:25:13 2008 +0100 @@ -398,6 +398,7 @@ let fundecl f = use_date := Reg.Map.empty; { fun_name = f.fun_name; fun_args = f.fun_args; + fun_dbg = f.fun_dbg; fun_body = new_body; fun_fast = f.fun_fast } diff -r 8c3eb45b53c2 asmcomp/split.ml --- a/asmcomp/split.ml Tue Nov 11 18:35:39 2008 +0100 +++ b/asmcomp/split.ml Wed Nov 12 00:25:13 2008 +0100 @@ -206,5 +206,6 @@ let fundecl f = equiv_classes := Reg.Map.empty; { fun_name = f.fun_name; fun_args = new_args; + fun_dbg = f.fun_dbg; fun_body = new_body; fun_fast = f.fun_fast } ![]() --- emit.mlp.0 2009-12-18 23:22:31.877582533 -0600 +++ emit.mlp 2009-12-18 23:24:37.967549612 -0600 @@ -657,6 +657,9 @@ (* Emission of a function declaration *) +open Debuginfo +let file_counter = ref 1 + let fundecl fundecl = function_name := fundecl.fun_name; fastcode_flag := fundecl.fun_fast; @@ -674,6 +677,18 @@ else ` .globl {emit_symbol fundecl.fun_name}\n`; `{emit_symbol fundecl.fun_name}:\n`; + if !Clflags.debug then begin + let dbg = fundecl.fun_dbg in + let file_name = dbg.dinfo_file + and file_num=(!file_counter) + and file_line=dbg.dinfo_line + in + if file_name<>"" then begin + `\t.file {emit_int file_num} \"{emit_string file_name}\"\n`; + `\t.loc {emit_int file_num} {emit_int file_line}\n`; + incr file_counter; + end; + end; if !Clflags.gprofile then emit_profile(); if frame_required() then begin let n = frame_size() - 8 in ![]() diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 473c634..978f523 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -661,8 +661,28 @@ let emit_profile () = | _ -> () (*unsupported yet*) -(* Emission of a function declaration *) +(* This assoc list is expected to be very short *) +let file_pos_nums = + (ref [] : (string * int) list ref) + +let file_pos_num_cnt = ref 1 + +let emit_debug_pos dbg = + if !Clflags.debug && dbg <> Debuginfo.none then + let file_num = + let fname = dbg.Debuginfo.dinfo_file in + try + List.assoc fname !file_pos_nums + with Not_found -> + let file_num = !file_pos_num_cnt in + incr file_pos_num_cnt; + ` .file {emit_int file_num} {emit_string_literal fname}\n`; + file_pos_nums := (fname,file_num) :: !file_pos_nums; + file_num + in + ` .loc {emit_int file_num} {emit_int dbg.Debuginfo.dinfo_line}\n` +(* Emission of a function declaration *) let fundecl fundecl = function_name := fundecl.fun_name; fastcode_flag := fundecl.fun_fast; @@ -682,6 +702,7 @@ let fundecl fundecl = else ` .globl {emit_symbol fundecl.fun_name}\n`; `{emit_symbol fundecl.fun_name}:\n`; + emit_debug_pos fundecl.fun_dbg; if !Clflags.gprofile then emit_profile(); if frame_required() then begin let n = frame_size() - 8 in diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml index 9bcb36f..b296a60 100644 --- a/asmcomp/clambda.ml +++ b/asmcomp/clambda.ml @@ -25,7 +25,8 @@ type ulambda = | Uconst of structured_constant * string option | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t - | Uclosure of (function_label * int * Ident.t list * ulambda) list + | Uclosure of + (function_label * int * Ident.t list * ulambda * Debuginfo.t) list * ulambda list | Uoffset of ulambda * int | Ulet of Ident.t * ulambda * ulambda @@ -54,7 +55,8 @@ type function_description = { fun_label: function_label; (* Label of direct entry point *) fun_arity: int; (* Number of arguments *) mutable fun_closed: bool; (* True if environment not used *) - mutable fun_inline: (Ident.t list * ulambda) option } + mutable fun_inline: (Ident.t list * ulambda) option; + fun_dbg: Debuginfo.t } (* Approximation of values *) diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli index 72ab857..0e51044 100644 --- a/asmcomp/clambda.mli +++ b/asmcomp/clambda.mli @@ -25,7 +25,8 @@ type ulambda = | Uconst of structured_constant * string option | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t - | Uclosure of (function_label * int * Ident.t list * ulambda) list + | Uclosure of + (function_label * int * Ident.t list * ulambda * Debuginfo.t) list * ulambda list | Uoffset of ulambda * int | Ulet of Ident.t * ulambda * ulambda @@ -54,7 +55,8 @@ type function_description = { fun_label: function_label; (* Label of direct entry point *) fun_arity: int; (* Number of arguments *) mutable fun_closed: bool; (* True if environment not used *) - mutable fun_inline: (Ident.t list * ulambda) option } + mutable fun_inline: (Ident.t list * ulambda) option; + fun_dbg: Debuginfo.t } (* Approximation of values *) diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index f37908f..0adc8ba 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -493,7 +493,7 @@ let rec close fenv cenv = function | Const_pointer n -> (Uconst (cst, None), Value_constptr n) | _ -> (Uconst (cst, Some (Compilenv.new_structured_constant cst true)), Value_unknown) end - | Lfunction(kind, params, body) as funct -> + | Lfunction(kind, params, body, _) as funct -> close_one_function fenv cenv (Ident.create "fun") funct (* We convert [f a] to [let a' = a in fun b c -> f a' b c] @@ -530,7 +530,7 @@ let rec close fenv cenv = function in let (new_fun, approx) = close fenv cenv (Lfunction( - Curried, final_args, Lapply(funct, internal_args, loc))) + Curried, final_args, Lapply(funct, internal_args, loc), loc)) in let new_fun = iter first_args new_fun in (new_fun, approx) @@ -564,7 +564,7 @@ let rec close fenv cenv = function end | Lletrec(defs, body) -> if List.for_all - (function (id, Lfunction(_, _, _)) -> true | _ -> false) + (function (id, Lfunction(_, _, _, _)) -> true | _ -> false) defs then begin (* Simple case: only function definitions *) @@ -692,7 +692,7 @@ and close_list_approx fenv cenv = function (ulam :: ulams, approx :: approxs) and close_named fenv cenv id = function - Lfunction(kind, params, body) as funct -> + Lfunction(kind, params, body, _) as funct -> close_one_function fenv cenv id funct | lam -> close fenv cenv lam @@ -713,14 +713,16 @@ and close_functions fenv cenv fun_defs = let uncurried_defs = List.map (function - (id, Lfunction(kind, params, body)) -> + (id, Lfunction(kind, params, body, loc)) -> let label = Compilenv.make_symbol (Some (Ident.unique_name id)) in let arity = List.length params in + let dbg = Debuginfo.from_location Debuginfo.Dinfo_call loc in let fundesc = {fun_label = label; fun_arity = (if kind = Tupled then -arity else arity); fun_closed = initially_closed; - fun_inline = None } in + fun_inline = None; + fun_dbg = dbg } in (id, params, body, fundesc) | (_, _) -> fatal_error "Closure.close_functions") fun_defs in @@ -756,7 +758,7 @@ and close_functions fenv cenv fun_defs = let (ubody, approx) = close fenv_rec cenv_body body in if !useless_env && occurs_var env_param ubody then useless_env := false; let fun_params = if !useless_env then params else params @ [env_param] in - ((fundesc.fun_label, fundesc.fun_arity, fun_params, ubody), + ((fundesc.fun_label, fundesc.fun_arity, fun_params, ubody,fundesc.fun_dbg), (id, env_pos, Value_closure(fundesc, approx))) in (* Translate all function definitions. *) let clos_info_list = @@ -786,7 +788,7 @@ and close_functions fenv cenv fun_defs = and close_one_function fenv cenv id funct = match close_functions fenv cenv [id, funct] with - ((Uclosure([_, _, params, body], _) as clos), + ((Uclosure([_, _, params, body, _], _) as clos), [_, _, (Value_closure(fundesc, _) as approx)]) -> (* See if the function can be inlined *) if lambda_smaller body (!Clflags.inline_threshold + List.length params) diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index 671ce5d..03c7e20 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -108,7 +108,8 @@ type fundecl = { fun_name: string; fun_args: (Ident.t * machtype) list; fun_body: expression; - fun_fast: bool } + fun_fast: bool; + fun_dbg: Debuginfo.t } type data_item = Cdefine_symbol of string diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index 76c5085..8028f23 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -94,7 +94,8 @@ type fundecl = { fun_name: string; fun_args: (Ident.t * machtype) list; fun_body: expression; - fun_fast: bool } + fun_fast: bool; + fun_dbg: Debuginfo.t } type data_item = Cdefine_symbol of string diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 61fef31..9c2a13a 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -374,7 +374,7 @@ let make_float_alloc tag args = let fundecls_size fundecls = let sz = ref (-1) in List.iter - (fun (label, arity, params, body) -> + (fun (label, arity, params, body, dbg) -> sz := !sz + 1 + (if arity = 1 then 2 else 3)) fundecls; !sz @@ -450,7 +450,9 @@ let transl_constant = function (* Translate constant closures *) let constant_closures = - ref ([] : (string * (string * int * Ident.t list * ulambda) list) list) + ref ([] : (string * (string * int * Ident.t list * ulambda * Debuginfo.t) + list) + list) (* Boxed integers *) @@ -797,7 +799,8 @@ let subst_boxed_number unbox_fn boxed_id unboxed_id exp = (* Translate an expression *) -let functions = (Queue.create() : (string * Ident.t list * ulambda) Queue.t) +let functions = (Queue.create() : + (string * Ident.t list * ulambda * Debuginfo.t) Queue.t) let rec transl = function Uvar id -> @@ -810,8 +813,8 @@ let rec transl = function let lbl = Compilenv.new_const_symbol() in constant_closures := (lbl, fundecls) :: !constant_closures; List.iter - (fun (label, arity, params, body) -> - Queue.add (label, params, body) functions) + (fun (label, arity, params, body, dbg) -> + Queue.add (label, params, body, dbg) functions) fundecls; Cconst_symbol lbl | Uclosure(fundecls, clos_vars) -> @@ -820,8 +823,8 @@ let rec transl = function let rec transl_fundecls pos = function [] -> List.map transl clos_vars - | (label, arity, params, body) :: rem -> - Queue.add (label, params, body) functions; + | (label, arity, params, body, dbg) :: rem -> + Queue.add (label, params, body, dbg) functions; let header = if pos = 0 then alloc_closure_header block_size @@ -1529,11 +1532,14 @@ and transl_letrec bindings cont = (* Translate a function definition *) -let transl_function lbl params body = +let transl_function lbl params body dbg = +(* print_endline dbg.Debuginfo.dinfo_file; + exit 127; *) Cfunction {fun_name = lbl; fun_args = List.map (fun id -> (id, typ_addr)) params; fun_body = transl body; - fun_fast = !Clflags.optimize_for_speed} + fun_fast = !Clflags.optimize_for_speed; + fun_dbg = dbg } (* Translate all function definitions *) @@ -1545,12 +1551,12 @@ module StringSet = let rec transl_all_functions already_translated cont = try - let (lbl, params, body) = Queue.take functions in + let (lbl, params, body, dbg) = Queue.take functions in if StringSet.mem lbl already_translated then transl_all_functions already_translated cont else begin transl_all_functions (StringSet.add lbl already_translated) - (transl_function lbl params body :: cont) + (transl_function lbl params body dbg :: cont) end with Queue.Empty -> cont @@ -1682,10 +1688,10 @@ and emit_boxed_int64_constant n cont = let emit_constant_closure symb fundecls cont = match fundecls with [] -> assert false - | (label, arity, params, body) :: remainder -> + | (label, arity, params, body, dbg) :: remainder -> let rec emit_others pos = function [] -> cont - | (label, arity, params, body) :: rem -> + | (label, arity, params, body, dbg) :: rem -> if arity = 1 then Cint(infix_header pos) :: Csymbol_address label :: @@ -1737,7 +1743,8 @@ let compunit size ulam = let init_code = transl ulam in let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry"); fun_args = []; - fun_body = init_code; fun_fast = false}] in + fun_body = init_code; fun_fast = false; + fun_dbg = Debuginfo.none }] in let c2 = transl_all_functions StringSet.empty c1 in let c3 = emit_all_constants c2 in Cdata [Cint(block_header 0 size); @@ -1866,7 +1873,8 @@ let send_function arity = {fun_name = "caml_send" ^ string_of_int arity; fun_args = fun_args; fun_body = body; - fun_fast = true} + fun_fast = true; + fun_dbg = Debuginfo.none } let apply_function arity = let (args, clos, body) = apply_function_body arity in @@ -1875,7 +1883,8 @@ let apply_function arity = {fun_name = "caml_apply" ^ string_of_int arity; fun_args = List.map (fun id -> (id, typ_addr)) all_args; fun_body = body; - fun_fast = true} + fun_fast = true; + fun_dbg = Debuginfo.none } (* Generate tuplifying functions: (defun caml_tuplifyN (arg clos) @@ -1894,7 +1903,8 @@ let tuplify_function arity = fun_body = Cop(Capply(typ_addr, Debuginfo.none), get_field (Cvar clos) 2 :: access_components 0 @ [Cvar clos]); - fun_fast = true} + fun_fast = true; + fun_dbg = Debuginfo.none } (* Generate currying functions: (defun caml_curryN (arg clos) @@ -1945,7 +1955,8 @@ let final_curry_function arity = "_" ^ string_of_int (arity-1); fun_args = [last_arg, typ_addr; last_clos, typ_addr]; fun_body = curry_fun [] last_clos (arity-1); - fun_fast = true} + fun_fast = true; + fun_dbg = Debuginfo.none } let rec intermediate_curry_functions arity num = if num = arity - 1 then @@ -1970,7 +1981,8 @@ let rec intermediate_curry_functions arity num = [alloc_closure_header 4; Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)); int_const 1; Cvar arg; Cvar clos]); - fun_fast = true} + fun_fast = true; + fun_dbg = Debuginfo.none} :: (if arity - num > 2 then let rec iter i = @@ -1996,7 +2008,8 @@ let rec intermediate_curry_functions arity num = fun_args = direct_args @ [clos, typ_addr]; fun_body = iter (num+1) (List.map (fun (arg,_) -> Cvar arg) direct_args) clos; - fun_fast = true} + fun_fast = true; + fun_dbg = Debuginfo.none} in cf :: intermediate_curry_functions arity (num+1) else @@ -2052,7 +2065,8 @@ let entry_point namelist = Cfunction {fun_name = "caml_program"; fun_args = []; fun_body = body; - fun_fast = false} + fun_fast = false; + fun_dbg = Debuginfo.none} (* Generate the table of globals *) diff --git a/asmcomp/debuginfo.ml b/asmcomp/debuginfo.ml index ad676d6..f14e239 100644 --- a/asmcomp/debuginfo.ml +++ b/asmcomp/debuginfo.ml @@ -38,7 +38,8 @@ let to_string d = d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end let from_location kind loc = - if loc.loc_ghost then none else + (* if loc.loc_ghost then none else *) + if loc.loc_start.pos_fname = "_loc_" then none else { dinfo_kind = kind; dinfo_file = loc.loc_start.pos_fname; dinfo_line = loc.loc_start.pos_lnum; diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index a5c7588..6c1d2fa 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -54,7 +54,9 @@ let has_fallthrough = function type fundecl = { fun_name: string; fun_body: instruction; - fun_fast: bool } + fun_fast: bool; + fun_dbg: Debuginfo.t + } (* Invert a test *) @@ -264,4 +266,6 @@ let rec linear i n = let fundecl f = { fun_name = f.Mach.fun_name; fun_body = linear f.Mach.fun_body end_instr; - fun_fast = f.Mach.fun_fast } + fun_fast = f.Mach.fun_fast; + fun_dbg = f.Mach.fun_dbg; + } diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli index ca11006..956633a 100644 --- a/asmcomp/linearize.mli +++ b/asmcomp/linearize.mli @@ -49,6 +49,7 @@ val invert_test: Mach.test -> Mach.test type fundecl = { fun_name: string; fun_body: instruction; - fun_fast: bool } + fun_fast: bool; + fun_dbg: Debuginfo.t } val fundecl: Mach.fundecl -> fundecl diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index b628f76..fdcb17a 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -79,7 +79,8 @@ type fundecl = { fun_name: string; fun_args: Reg.t array; fun_body: instruction; - fun_fast: bool } + fun_fast: bool; + fun_dbg: Debuginfo.t } let rec dummy_instr = { desc = Iend; diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index dd58b8a..0ca4a39 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -79,7 +79,8 @@ type fundecl = { fun_name: string; fun_args: Reg.t array; fun_body: instruction; - fun_fast: bool } + fun_fast: bool; + fun_dbg: Debuginfo.t } val dummy_instr: instruction val end_instr: unit -> instruction diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml index fc28acd..cc05c4b 100644 --- a/asmcomp/reloadgen.ml +++ b/asmcomp/reloadgen.ml @@ -134,7 +134,7 @@ method fundecl f = redo_regalloc <- false; let new_body = self#reload f.fun_body in ({fun_name = f.fun_name; fun_args = f.fun_args; - fun_body = new_body; fun_fast = f.fun_fast}, + fun_body = new_body; fun_fast = f.fun_fast; fun_dbg = f.fun_dbg }, redo_regalloc) end diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml index a5dfcfd..d8fb4d0 100644 --- a/asmcomp/schedgen.ml +++ b/asmcomp/schedgen.ml @@ -349,7 +349,8 @@ method schedule_fundecl f = clear_code_dag(); { fun_name = f.fun_name; fun_body = new_body; - fun_fast = f.fun_fast } + fun_fast = f.fun_fast; + fun_dbg = f.fun_dbg } end else f diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 106d42b..98acbea 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -821,7 +821,8 @@ method emit_fundecl f = { fun_name = f.Cmm.fun_name; fun_args = loc_arg; fun_body = self#extract; - fun_fast = f.Cmm.fun_fast } + fun_fast = f.Cmm.fun_fast; + fun_dbg = f.Cmm.fun_dbg } end diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index 874f735..a92d19a 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -399,4 +399,5 @@ let fundecl f = { fun_name = f.fun_name; fun_args = f.fun_args; fun_body = new_body; - fun_fast = f.fun_fast } + fun_fast = f.fun_fast; + fun_dbg = f.fun_dbg } diff --git a/asmcomp/split.ml b/asmcomp/split.ml index 8c5e227..79bcdc5 100644 --- a/asmcomp/split.ml +++ b/asmcomp/split.ml @@ -207,4 +207,5 @@ let fundecl f = { fun_name = f.fun_name; fun_args = new_args; fun_body = new_body; - fun_fast = f.fun_fast } + fun_fast = f.fun_fast; + fun_dbg = f.fun_dbg } diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 9773f0b..681aee7 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -141,7 +141,7 @@ let rec check_recordwith_updates id e = ;; let rec size_of_lambda = function - | Lfunction(kind, params, body) as funct -> + | Lfunction(kind, params, body, loc) as funct -> RHS_block (1 + IdentSet.cardinal(free_variables funct)) | Llet (Strict, id, Lprim (Pduprecord (kind, size), _), body) when check_recordwith_updates id body -> @@ -450,7 +450,7 @@ let rec comp_expr env exp sz cont = comp_args env args' (sz + 3) (getmethod :: Kapply nargs :: cont1) end - | Lfunction(kind, params, body) -> (* assume kind = Curried *) + | Lfunction(kind, params, body, _) -> (* assume kind = Curried *) let lbl = new_label() in let fv = IdentSet.elements(free_variables exp) in let to_compile = @@ -465,7 +465,7 @@ let rec comp_expr env exp sz cont = (add_pop 1 cont)) | Lletrec(decl, body) -> let ndecl = List.length decl in - if List.for_all (function (_, Lfunction(_,_,_)) -> true | _ -> false) + if List.for_all (function (_, Lfunction(_,_,_,_)) -> true | _ -> false) decl then begin (* let rec of functions *) let fv = @@ -473,7 +473,7 @@ let rec comp_expr env exp sz cont = let rec_idents = List.map (fun (id, lam) -> id) decl in let rec comp_fun pos = function [] -> [] - | (id, Lfunction(kind, params, body)) :: rem -> + | (id, Lfunction(kind, params, body, _)) :: rem -> let lbl = new_label() in let to_compile = { params = params; body = body; label = lbl; free_vars = fv; diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index b1e6f16..ce90104 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -127,7 +127,7 @@ type lambda = Lvar of Ident.t | Lconst of structured_constant | Lapply of lambda * lambda list * Location.t - | Lfunction of function_kind * Ident.t list * lambda + | Lfunction of function_kind * Ident.t list * lambda * Location.t | Llet of let_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda | Lprim of primitive * lambda list @@ -174,7 +174,7 @@ let rec same l1 l2 = c1 = c2 | Lapply(a1, bl1, _), Lapply(a2, bl2, _) -> same a1 a2 && samelist same bl1 bl2 - | Lfunction(k1, idl1, a1), Lfunction(k2, idl2, a2) -> + | Lfunction(k1, idl1, a1, _), Lfunction(k2, idl2, a2, _) -> k1 = k2 && samelist Ident.same idl1 idl2 && same a1 a2 | Llet(k1, id1, a1, b1), Llet(k2, id2, a2, b2) -> k1 = k2 && Ident.same id1 id2 && same a1 a2 && same b1 b2 @@ -244,7 +244,7 @@ let rec iter f = function | Lconst _ -> () | Lapply(fn, args, _) -> f fn; List.iter f args - | Lfunction(kind, params, body) -> + | Lfunction(kind, params, body, _) -> f body | Llet(str, id, arg, body) -> f arg; f body @@ -296,7 +296,7 @@ let free_ids get l = iter free l; fv := List.fold_right IdentSet.add (get l) !fv; match l with - Lfunction(kind, params, body) -> + Lfunction(kind, params, body, loc) -> List.iter (fun param -> fv := IdentSet.remove param !fv) params | Llet(str, id, arg, body) -> fv := IdentSet.remove id !fv @@ -377,7 +377,8 @@ let subst_lambda s lam = begin try Ident.find_same id s with Not_found -> l end | Lconst sc as l -> l | Lapply(fn, args, loc) -> Lapply(subst fn, List.map subst args, loc) - | Lfunction(kind, params, body) -> Lfunction(kind, params, subst body) + | Lfunction(kind, params, body, loc) -> + Lfunction(kind, params, subst body,loc) | Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body) | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body) | Lprim(p, args) -> Lprim(p, List.map subst args) diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index d09a8c6..6646f35 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -136,7 +136,7 @@ type lambda = Lvar of Ident.t | Lconst of structured_constant | Lapply of lambda * lambda list * Location.t - | Lfunction of function_kind * Ident.t list * lambda + | Lfunction of function_kind * Ident.t list * lambda * Location.t | Llet of let_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda | Lprim of primitive * lambda list diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 38182db..74c3751 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -192,7 +192,7 @@ let rec lam ppf = function let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs - | Lfunction(kind, params, body) -> + | Lfunction(kind, params, body, _) -> let pr_params ppf params = match kind with | Curried -> diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index e26524e..634e0a2 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -28,7 +28,7 @@ let rec eliminate_ref id = function | Lconst cst as lam -> lam | Lapply(e1, el, loc) -> Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, loc) - | Lfunction(kind, params, body) as lam -> + | Lfunction(kind, params, body, _) as lam -> if IdentSet.mem id (free_variables lam) then raise Real_reference else lam @@ -105,7 +105,7 @@ let simplify_exits lam = let rec count = function | (Lvar _| Lconst _) -> () | Lapply(l1, ll, _) -> count l1; List.iter count ll - | Lfunction(kind, params, l) -> count l + | Lfunction(kind, params, l, _) -> count l | Llet(str, v, l1, l2) -> count l2; count l1 | Lletrec(bindings, body) -> @@ -186,7 +186,7 @@ let simplify_exits lam = let rec simplif = function | (Lvar _|Lconst _) as l -> l | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc) - | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l) + | Lfunction(kind, params, l, loc) -> Lfunction(kind, params, simplif l, loc) | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2) | Lletrec(bindings, body) -> Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) @@ -305,7 +305,7 @@ let simplify_lets lam = use_var bv v 1 | Lapply(l1, ll, _) -> count bv l1; List.iter (count bv) ll - | Lfunction(kind, params, l) -> + | Lfunction(kind, params, l, _) -> count Tbl.empty l | Llet(str, v, Lvar w, l2) when not !Clflags.debug -> (* v will be replaced by w in l2, so each occurrence of v in l2 @@ -380,7 +380,7 @@ let simplify_lets lam = end | Lconst cst as l -> l | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc) - | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l) + | Lfunction(kind, params, l, loc) -> Lfunction(kind, params, simplif l, loc) | Llet(str, v, Lvar w, l2) when optimize -> Hashtbl.add subst v (simplif (Lvar w)); simplif l2 @@ -459,7 +459,7 @@ let rec emit_tail_infos is_tail lambda = | Lapply (func, l, loc) -> list_emit_tail_infos false l; Stypes.record (Stypes.An_call (loc, call_kind l)) - | Lfunction (_, _, lam) -> + | Lfunction (_, _, lam, _) -> emit_tail_infos true lam | Llet (_, _, lam, body) -> emit_tail_infos false lam; diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index f06e43b..3e616c8 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -26,13 +26,13 @@ type error = Illegal_class_expr | Tags of label * label exception Error of Location.t * error -let lfunction params body = +let lfunction params body loc = if params = [] then body else match body with - Lfunction (Curried, params', body') -> - Lfunction (Curried, params @ params', body') + Lfunction (Curried, params', body', _) -> + Lfunction (Curried, params @ params', body', loc) | _ -> - Lfunction (Curried, params, body) + Lfunction (Curried, params, body, loc) let lapply func args loc = match func with @@ -169,11 +169,12 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = let param = name_pattern "param" [pat, ()] in Lfunction (Curried, param::params, Matching.for_function - pat.pat_loc None (Lvar param) [pat, rem] partial) + pat.pat_loc None (Lvar param) [pat, rem] partial, + cl.cl_loc) in begin match obj_init with - Lfunction (Curried, params, rem) -> build params rem - | rem -> build [] rem + Lfunction (Curried, params, rem, _) -> build params rem + | rem -> build [] rem end) | Tclass_apply (cl, oexprs) -> let (inh_init, obj_init) = @@ -200,8 +201,8 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = let ((_,inh_init), obj_init) = build_object_init cl_table obj params (envs,[]) (copy_env env) cl in let obj_init = - if ids = [] then obj_init else lfunction [self] obj_init in - (inh_init, lfunction [env] (subst_env env inh_init obj_init)) + if ids = [] then obj_init else lfunction [self] obj_init cl.cl_loc in + (inh_init, lfunction [env] (subst_env env inh_init obj_init) cl.cl_loc) let bind_method tbl lab id cl_init = @@ -404,12 +405,13 @@ let rec transl_class_rebind obj_init cl vf = let param = name_pattern "param" [pat, ()] in Lfunction (Curried, param::params, Matching.for_function - pat.pat_loc None (Lvar param) [pat, rem] partial) + pat.pat_loc None (Lvar param) [pat, rem] partial, + cl.cl_loc) in (path, match obj_init with - Lfunction (Curried, params, rem) -> build params rem - | rem -> build [] rem) + Lfunction (Curried, params, rem, _) -> build params rem + | rem -> build [] rem) | Tclass_apply (cl, oexprs) -> let path, obj_init = transl_class_rebind obj_init cl vf in (path, transl_apply obj_init oexprs Location.none) @@ -434,7 +436,7 @@ let rec transl_class_rebind_0 self obj_init cl vf = (path, Translcore.transl_let rec_flag defs obj_init) | _ -> let path, obj_init = transl_class_rebind obj_init cl vf in - (path, lfunction [self] obj_init) + (path, lfunction [self] obj_init cl.cl_loc) let transl_class_rebind ids cl vf = try @@ -444,7 +446,7 @@ let transl_class_rebind ids cl vf = let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in if not (Translcore.check_recursive_lambda ids obj_init') then raise(Error(cl.cl_loc, Illegal_class_expr)); - let id = (obj_init' = lfunction [self] obj_init0) in + let id = (obj_init' = lfunction [self] obj_init0 cl.cl_loc) in if id then transl_path path else let cla = Ident.create "class" @@ -453,7 +455,7 @@ let transl_class_rebind ids cl vf = and table = Ident.create "table" and envs = Ident.create "envs" in Llet( - Strict, new_init, lfunction [obj_init] obj_init', + Strict, new_init, lfunction [obj_init] obj_init' cl.cl_loc, Llet( Alias, cla, transl_path path, Lprim(Pmakeblock(0, Immutable), @@ -463,7 +465,9 @@ let transl_class_rebind ids cl vf = mkappl(lfield cla 1, [Lvar table]), lfunction [envs] (mkappl(Lvar new_init, - [mkappl(Lvar env_init, [Lvar envs])])))); + [mkappl(Lvar env_init, [Lvar envs])])) + cl.cl_loc)) + cl.cl_loc; lfield cla 2; lfield cla 3]))) with Exit -> @@ -481,7 +485,7 @@ let rec module_path = function let const_path local = function Lvar id -> not (List.mem id local) | Lconst _ -> true - | Lfunction (Curried, _, body) -> + | Lfunction (Curried, _, body, _) -> let fv = free_variables body in List.for_all (fun x -> not (IdentSet.mem x fv)) local | p -> module_path p @@ -521,7 +525,7 @@ let rec builtin_meths self env env2 body = | Lsend(Cached, met, arg, [_;_], _) -> let s, args = conv arg in ("send_"^s, met :: args) - | Lfunction (Curried, [x], body) -> + | Lfunction (Curried, [x], body, _) -> let rec enter self = function | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x']) when Ident.same x x' && List.mem s self -> @@ -629,7 +633,7 @@ let transl_class ids cl_id arity pub_meths cl vflag = in let new_ids_meths = ref [] in let msubst arr = function - Lfunction (Curried, self :: args, body) -> + Lfunction (Curried, self :: args, body, loc) -> let env = Ident.create "env" in let body' = if new_ids = [] then body else @@ -638,13 +642,14 @@ let transl_class ids cl_id arity pub_meths cl vflag = (* Doesn't seem to improve size for bytecode *) (* if not !Clflags.native_code then raise Not_found; *) if not arr || !Clflags.debug then raise Not_found; - builtin_meths [self] env env2 (lfunction args body') + builtin_meths [self] env env2 (lfunction args body' loc) with Not_found -> [lfunction (self :: args) (if not (IdentSet.mem env (free_variables body')) then body' else Llet(Alias, env, Lprim(Parrayrefu Paddrarray, - [Lvar self; Lvar env2]), body'))] + [Lvar self; Lvar env2]), body')) + loc ] end | _ -> assert false in @@ -703,7 +708,7 @@ let transl_class ids cl_id arity pub_meths cl vflag = let concrete = (vflag = Concrete) and lclass lam = - let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in + let cl_init = llets (Lfunction(Curried, [cla], cl_init,cl.cl_loc)) in Llet(Strict, class_init, cl_init, lam (free_variables cl_init)) and lbody fv = if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then @@ -720,7 +725,7 @@ let transl_class ids cl_id arity pub_meths cl vflag = Lvar class_init; Lvar env_init; lambda_unit])))) and lbody_virt lenvs = Lprim(Pmakeblock(0, Immutable), - [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs]) + [lambda_unit; Lfunction(Curried,[cla], cl_init, cl.cl_loc); lambda_unit; lenvs]) in (* Still easy: a class defined at toplevel *) if top && concrete then lclass lbody else @@ -762,7 +767,7 @@ let transl_class ids cl_id arity pub_meths cl vflag = List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in let lclass lam = Llet(Strict, class_init, - Lfunction(Curried, [cla], def_ids cla cl_init), lam) + Lfunction(Curried, [cla], def_ids cla cl_init, cl.cl_loc), lam) and lcache lam = if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else Llet(Strict, cached, @@ -778,7 +783,7 @@ let transl_class ids cl_id arity pub_meths cl vflag = Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), lset cached 0 (Lvar env_init)))) and lclass_virt () = - lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init)) + lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init, cl.cl_loc)) in llets ( lcache ( diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 9441fcc..6d96233 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -361,12 +361,12 @@ let transl_primitive p = match prim with Plazyforce -> let parm = Ident.create "prim" in - Lfunction(Curried, [parm], Matching.inline_lazy_force (Lvar parm) Location.none) + Lfunction(Curried, [parm], Matching.inline_lazy_force (Lvar parm) Location.none, Location.none) | _ -> let rec make_params n = if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in let params = make_params p.prim_arity in - Lfunction(Curried, params, Lprim(prim, List.map (fun id -> Lvar id) params)) + Lfunction(Curried, params, Lprim(prim, List.map (fun id -> Lvar id) params), Location.none) (* To check the well-formedness of r.h.s. of "let rec" definitions *) @@ -388,7 +388,7 @@ let check_recursive_lambda idlist lam = and check idlist = function | Lvar _ -> true - | Lfunction(kind, params, body) -> true + | Lfunction(kind, params, body, _) -> true | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam -> true | Llet(str, id, arg, body) -> @@ -564,12 +564,12 @@ and transl_exp0 e = if public_send || p.prim_name = "%sendself" then let kind = if public_send then Public else Self in let obj = Ident.create "obj" and meth = Ident.create "meth" in - Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc)) + Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc),e.exp_loc) else if p.prim_name = "%sendcache" then let obj = Ident.create "obj" and meth = Ident.create "meth" in let cache = Ident.create "cache" and pos = Ident.create "pos" in Lfunction(Curried, [obj; meth; cache; pos], - Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc)) + Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc),e.exp_loc) else transl_primitive p | Texp_ident(path, {val_kind = Val_anc _}) -> @@ -588,7 +588,7 @@ and transl_exp0 e = let pl = push_defaults e.exp_loc [] pat_expr_list partial in transl_function e.exp_loc !Clflags.native_code repr partial pl) in - Lfunction(kind, params, body) + Lfunction(kind, params, body, e.exp_loc) | Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, oargs) when List.length oargs >= p.prim_arity && List.for_all (fun (arg,_) -> arg <> None) oargs -> @@ -809,7 +809,8 @@ and transl_exp0 e = end (* other cases compile to a lazy block holding a function *) | _ -> - let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in + let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e, + e.exp_loc) in Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn]) end | Texp_object (cs, cty, meths) -> @@ -864,12 +865,13 @@ and transl_apply lam sargs loc = and id_arg = Ident.create "param" in let body = match build_apply handle ((Lvar id_arg, optional)::args') l with - Lfunction(Curried, ids, lam) -> - Lfunction(Curried, id_arg::ids, lam) - | Levent(Lfunction(Curried, ids, lam), _) -> - Lfunction(Curried, id_arg::ids, lam) + Lfunction(Curried, ids, lam, loc) -> + Lfunction(Curried, id_arg::ids, lam, loc) + | Levent(Lfunction(Curried, ids, lam, loc), _) -> + Lfunction(Curried, id_arg::ids, lam, loc) | lam -> - Lfunction(Curried, [id_arg], lam) + (* TODO: till *) + Lfunction(Curried, [id_arg], lam, Location.none) in List.fold_left (fun body (id, lam) -> Llet(Strict, id, lam, body)) diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index a80fee6..47cfd97 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -48,7 +48,8 @@ let rec apply_coercion restr arg = Lfunction(Curried, [param], apply_coercion cc_res (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)], - Location.none)))) + Location.none)), + Location.none)) | Tcoerce_primitive p -> transl_primitive p @@ -244,12 +245,14 @@ let rec transl_module cc rootpath mexp = (function | Tcoerce_none -> Lfunction(Curried, [param], - transl_module Tcoerce_none bodypath body) + transl_module Tcoerce_none bodypath body, + mexp.mod_loc) | Tcoerce_functor(ccarg, ccres) -> let param' = Ident.create "funarg" in Lfunction(Curried, [param'], Llet(Alias, param, apply_coercion ccarg (Lvar param'), - transl_module ccres bodypath body)) + transl_module ccres bodypath body), + mexp.mod_loc) | _ -> fatal_error "Translmod.transl_module") cc | |||||||
![]() |
||||||
|
![]() |
|
(0005202) dschauer (reporter) 2009-12-19 06:52 |
I had to patch asmcomp/amd64/emit.mlp as well in order for the patch-file-and-loc-v1-cvs-2008-11-11.patch to do me any good. At least I can break on function entry points now. |
(0005224) doligez (administrator) 2010-01-07 16:24 |
In order to do this properly, we'll have to propagate location information through the back-end. A good idea, but a lot of work. |
(0006137) till (reporter) 2011-09-30 16:03 edited on: 2011-09-30 18:47 |
I tried to redo the patch propagating the location from the type system, see: file_pos_amd64.patch (Patch on the tip of the repo) |
(0006320) tgazagna (reporter) 2011-12-16 10:57 edited on: 2011-12-22 12:16 |
Recently, I've worked enhancing the support of GDB. The result is a serie of patches against 3.12.1 (including some patches from ygrek and Till). If there is an interest, I can pass some time to port them to trunk: https://github.com/OCamlPro/ocaml-testing/compare/3.12.1...3.12.1-gdb [^] Feedback welcome. |
(0007075) xleroy (administrator) 2012-03-14 17:57 |
I believe (correct me if I'm wrong) that this functionality is part of Thomas Gazagnaire's patch (PR#5487), which is now merged in and will appear in release 4.00. |
![]() |
|||
Date Modified | Username | Field | Change |
2009-10-05 13:44 | apoirot | New Issue | |
2009-10-05 13:44 | apoirot | File Added: patch-file-and-loc-v1-cvs-2008-11-11.patch | |
2009-12-19 06:44 | dschauer | File Added: patch-file-and-loc-amd64-0.patch | |
2009-12-19 06:52 | dschauer | Note Added: 0005202 | |
2010-01-07 16:24 | doligez | Note Added: 0005224 | |
2010-01-07 16:24 | doligez | Status | new => acknowledged |
2011-09-30 16:03 | till | Note Added: 0006137 | |
2011-09-30 16:04 | till | File Added: file_pos_amd64.patch | |
2011-09-30 18:47 | till | Note Edited: 0006137 | |
2011-12-16 10:57 | tgazagna | Note Added: 0006320 | |
2011-12-16 10:57 | tgazagna | Note Edited: 0006320 | View Revisions |
2011-12-22 12:16 | tgazagna | Note Edited: 0006320 | View Revisions |
2012-03-14 17:55 | xleroy | Relationship added | related to 0005487 |
2012-03-14 17:57 | xleroy | Note Added: 0007075 | |
2012-03-14 17:57 | xleroy | Status | acknowledged => resolved |
2012-03-14 17:57 | xleroy | Resolution | open => fixed |
2012-03-14 17:57 | xleroy | Fixed in Version | => 3.13.0+dev |
2013-08-31 12:48 | xleroy | Status | resolved => closed |
2017-02-23 16:36 | doligez | Category | OCaml general => -OCaml general |
2017-03-03 17:55 | doligez | Category | -OCaml general => -(deprecated) general |
2017-03-03 18:01 | doligez | Category | -(deprecated) general => ~deprecated (was: OCaml general) |
2017-03-06 17:04 | doligez | Category | ~deprecated (was: OCaml general) => ~DO NOT USE (was: OCaml general) |
Copyright © 2000 - 2011 MantisBT Group |