Corrections de bugs dans la gestion des evenements de debug.

Conserver l'optimisation tailcall et push-acc meme en presence
d'evenements de debug.
Stockage plus efficace des infos de debug dans les .cmo.


git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@1279 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

10 files changed, 64 insertions, 25 deletions

diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index 5624d4715..7f33bb7d0 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -123,6 +123,10 @@ and sz_staticfail = ref 0
 let functions_to_compile  =
   (Stack.create () : (Ident.t list * lambda * label * Ident.t list) Stack.t)
 
+(* Name of current compilation unit (for debugging events) *)
+
+let compunit_name = ref ""
+
 (* Compile an expression.
    The value of the expression is left in the accumulator.
    env = compilation environment
@@ -395,7 +399,7 @@ let rec comp_expr env exp sz cont =
   | Levent(lam, lev) ->
       let ev =
         { ev_pos = 0;                   (* patched in emitcode *)
-          ev_file = !Location.input_name;
+          ev_module = !compunit_name;
           ev_char = lev.lev_loc;
           ev_kind = begin match lev.lev_kind with
                       Lev_before -> Event_before
@@ -413,12 +417,16 @@ let rec comp_expr env exp sz cont =
           | _ -> Kevent ev :: c
           end
       | Lev_after ty ->
-          let cont1 =
-            (* Discard following events, supposedly less informative *)
-            match cont with
-              Kevent _ :: c -> c
-            | _ -> cont in
-          comp_expr env lam sz (Kevent ev :: cont1)
+          if is_tailcall cont then      (* don't destroy tail call opt *)
+            comp_expr env lam sz cont
+          else begin
+            let cont1 =
+              (* Discard following events, supposedly less informative *)
+              match cont with
+                Kevent _ :: c -> c
+              | _ -> cont in
+            comp_expr env lam sz (Kevent ev :: cont1)
+          end
       end
 
 (* Compile a list of arguments [e1; ...; eN] to a primitive operation.
@@ -485,11 +493,12 @@ let comp_remainder cont =
 
 (**** Compilation of a lambda phrase ****)
 
-let compile_implementation expr =
+let compile_implementation modulename expr =
   Stack.clear functions_to_compile;
   label_counter := 0;
   lbl_staticfail := 0;
   sz_staticfail := 0;
+  compunit_name := modulename;
   let init_code = comp_expr empty_env expr 0 [] in
   if Stack.length functions_to_compile > 0 then begin
     let lbl_init = new_label() in
diff --git a/bytecomp/bytegen.mli b/bytecomp/bytegen.mli
index d89781d07..1cde7e081 100644
--- a/bytecomp/bytegen.mli
+++ b/bytecomp/bytegen.mli
@@ -16,5 +16,5 @@
 open Lambda
 open Instruct
 
-val compile_implementation: lambda -> instruction list
+val compile_implementation: string -> lambda -> instruction list
 val compile_phrase: lambda -> instruction list * instruction list
diff --git a/bytecomp/bytelibrarian.ml b/bytecomp/bytelibrarian.ml
index 4fc8f870c..7890ee15c 100644
--- a/bytecomp/bytelibrarian.ml
+++ b/bytecomp/bytelibrarian.ml
@@ -27,7 +27,12 @@ let copy_compunit ic oc compunit =
   seek_in ic compunit.cu_pos;
   compunit.cu_pos <- pos_out oc;
   compunit.cu_force_link <- !Clflags.link_everything;
-  copy_file_chunk ic oc compunit.cu_codesize
+  copy_file_chunk ic oc compunit.cu_codesize;
+  if compunit.cu_debug > 0 then begin
+    seek_in ic compunit.cu_debug;
+    compunit.cu_debug <- pos_out oc;
+    copy_file_chunk ic oc compunit.cu_debugsize
+  end
 
 let copy_object_file oc name =
   let file_name =
diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml
index 9cd416455..3e7f31e27 100644
--- a/bytecomp/bytelink.ml
+++ b/bytecomp/bytelink.ml
@@ -151,7 +151,10 @@ let link_compunit output_fun currpos_fun inchan file_name compunit =
   let code_block = String.create compunit.cu_codesize in
   really_input inchan code_block 0 compunit.cu_codesize;
   Symtable.patch_object code_block compunit.cu_reloc;
-  if !Clflags.debug then record_events (currpos_fun()) compunit.cu_events;
+  if !Clflags.debug && compunit.cu_debug > 0 then begin
+    seek_in inchan compunit.cu_debug;
+    record_events (currpos_fun()) (input_value inchan : debug_event list)
+  end;
   output_fun code_block;
   if !Clflags.link_everything then
     List.iter Symtable.require_primitive compunit.cu_primitives
@@ -175,14 +178,15 @@ let link_archive output_fun currpos_fun file_name units_required =
   let inchan = open_in_bin file_name in
   try
     List.iter
-      (link_compunit output_fun currpos_fun inchan file_name)
+      (fun cu ->
+         let name = file_name ^ "(" ^ cu.cu_name ^ ")" in
+         try
+           link_compunit output_fun currpos_fun inchan name cu
+         with Symtable.Error msg ->
+           raise(Error(Symbol_error(name, msg))))
       units_required;
     close_in inchan
-  with
-    Symtable.Error msg ->
-      close_in inchan; raise(Error(Symbol_error(file_name, msg)))
-  | x ->
-      close_in inchan; raise x
+  with x -> close_in inchan; raise x
 
 (* Link in a .cmo or .cma file *)
 
diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
index 62fd5f1f2..76f7b52c4 100644
--- a/bytecomp/emitcode.ml
+++ b/bytecomp/emitcode.ml
@@ -40,7 +40,8 @@ type compilation_unit =
     cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *)
     cu_primitives: string list;         (* Primitives declared inside *)
     mutable cu_force_link: bool;        (* Must be linked even if unref'ed *)
-    cu_events: debug_event list }       (* Debugging events *)
+    mutable cu_debug: int;              (* Position of debugging info, or 0 *)
+    cu_debugsize: int }                 (* Length of debugging info *)
 
 (* Format of a .cmo file:
      magic number (Config.cmo_magic_number)
@@ -262,8 +263,8 @@ let rec emit = function
       emit c
   | Kpush :: Kgetglobal id :: Kgetfield n :: c ->
       out opPUSHGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c
-  | Kpush :: Kgetglobal q :: c ->
-      out opPUSHGETGLOBAL; slot_for_getglobal q; emit c
+  | Kpush :: Kgetglobal id :: c ->
+      out opPUSHGETGLOBAL; slot_for_getglobal id; emit c
   | Kpush :: Kconst sc :: c ->
       begin match sc with
         Const_base(Const_int i) when i >= immed_min & i <= immed_max ->
@@ -272,12 +273,22 @@ let rec emit = function
           else (out opPUSHCONSTINT; out_int i)
       | Const_base(Const_char c) ->
           out opPUSHCONSTINT; out_int(Char.code c)
+      | Const_pointer i ->
+          if i >= 0 & i <= 3
+          then out (opPUSHCONST0 + i)
+          else (out opPUSHCONSTINT; out_int i)
       | Const_block(t, []) ->
           if t = 0 then out opPUSHATOM0 else (out opPUSHATOM; out_int t)
       | _ ->
           out opPUSHGETGLOBAL; slot_for_literal sc
       end;
       emit c
+  | Kpush :: (Kevent {ev_kind = Event_before} as ev) ::
+    (Kgetglobal _ as instr1) :: (Kgetfield _ as instr2) :: c ->
+      emit (Kpush :: instr1 :: instr2 :: ev :: c)
+  | Kpush :: (Kevent {ev_kind = Event_before} as ev) ::
+    (Kacc _ | Kenvacc _ | Kgetglobal _ | Kconst _ as instr) :: c ->
+      emit (Kpush :: instr :: ev :: c)
   | Kgetglobal id :: Kgetfield n :: c ->
       out opGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c
   (* Default case *)
@@ -294,6 +305,13 @@ let to_file outchan unit_name crc_interface code =
   let pos_code = pos_out outchan in
   emit code;
   output outchan !out_buffer 0 !out_position;
+  let (pos_debug, size_debug) =
+    if !Clflags.debug then begin
+      let p = pos_out outchan in
+      output_value outchan !events;
+      (p, pos_out outchan - p)
+    end else
+      (0, 0) in
   let compunit =
     { cu_name = unit_name;
       cu_pos = pos_code;
@@ -303,7 +321,8 @@ let to_file outchan unit_name crc_interface code =
       cu_imports = Env.imported_units();
       cu_primitives = !Translmod.primitive_declarations;
       cu_force_link = false;
-      cu_events = !events } in
+      cu_debug = pos_debug;
+      cu_debugsize = size_debug } in
   init();                               (* Free out_buffer and reloc_info *)
   Types.cleanup_abbrev ();              (* Remove any cached abbreviation
                                            expansion before saving *)
diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli
index 365286d55..3ea843e2c 100644
--- a/bytecomp/emitcode.mli
+++ b/bytecomp/emitcode.mli
@@ -35,7 +35,8 @@ type compilation_unit =
     cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *)
     cu_primitives: string list;         (* Primitives declared inside *)
     mutable cu_force_link: bool;        (* Must be linked even if unref'ed *)
-    cu_events: debug_event list }       (* Debugging events *)
+    mutable cu_debug: int;              (* Position of debugging info, or 0 *)
+    cu_debugsize: int }                 (* Length of debugging info *)
 
 (* Format of a .cmo file:
      magic number (Config.cmo_magic_number)
diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml
index d86157ba3..b984ee6ed 100644
--- a/bytecomp/instruct.ml
+++ b/bytecomp/instruct.ml
@@ -19,7 +19,7 @@ type compilation_env =
 
 type debug_event =
   { mutable ev_pos: int;                (* Position in bytecode *)
-    ev_file: string;                    (* Source file name *)
+    ev_module: string;                  (* Name of defining module *)
     ev_char: int;                       (* Location in source file *)
     ev_kind: debug_event_kind;          (* Before/after event *)
     ev_typenv: Env.summary;             (* Typing environment *)
diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli
index 1958551ff..97fa90a2a 100644
--- a/bytecomp/instruct.mli
+++ b/bytecomp/instruct.mli
@@ -31,7 +31,7 @@ type compilation_env =
 
 type debug_event =
   { mutable ev_pos: int;                (* Position in bytecode *)
-    ev_file: string;                    (* Source file name *)
+    ev_module: string;                  (* Name of defining module *)
     ev_char: int;                       (* Location in source file *)
     ev_kind: debug_event_kind;          (* Before/after event *)
     ev_typenv: Env.summary;             (* Typing environment *)
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 825389866..0e7bcf768 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -184,6 +184,7 @@ let free_variables l =
 let rec is_guarded = function
     Lifthenelse(cond, body, Lstaticfail) -> true
   | Llet(str, id, lam, body) -> is_guarded body
+  | Levent(lam, ev) -> is_guarded lam
   | _ -> false
 
 let rec transl_path = function
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 8c15ff8f0..5725b4990 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -303,7 +303,7 @@ let rec name_pattern default = function
 (* Insertion of debugging events *)
 
 let event_before exp lam =
-  if !Clflags.debug
+  if !Clflags.debug && lam <> Lstaticfail
   then Levent(lam, {lev_loc = exp.exp_loc.Location.loc_start;
                     lev_kind = Lev_before;
                     lev_env = Env.summary exp.exp_env})