0004888: Improve again x86/ELF for GNU debugging tools

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 }

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

Issue History
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)

Notes
(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.