From 999bbd65319a1f6587d167082138d5986b1172c6 Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Thu, 22 Dec 2011 11:29:12 +0100
Subject: [PATCH 10/10] Emit debug information for each instruction on amd64

---
 asmcomp/amd64/emit.mlp |    1 +
 1 files changed, 1 insertions(+), 0 deletions(-)

diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
index 4aad39c..eca8397 100644
--- a/asmcomp/amd64/emit.mlp
+++ b/asmcomp/amd64/emit.mlp
@@ -366,6 +366,7 @@ let emit_debug_info dbg =
 
 (* Emit an instruction *)
 let emit_instr fallthrough i =
+    emit_debug_info i.dbg;
     match i.desc with
       Lend -> ()
     | Lop(Imove | Ispill | Ireload) ->
-- 
1.7.5.4

From 6f7c9f6eaf589ba20dff136edf245ffd5ee6dd31 Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Fri, 2 Dec 2011 12:26:46 +0100
Subject: [PATCH 01/10] Fix -dsplit ocamlopt option

---
 driver/main_args.ml |    2 ++
 1 files changed, 2 insertions(+), 0 deletions(-)

diff --git a/driver/main_args.ml b/driver/main_args.ml
index 279a463..0ec0ef7 100644
--- a/driver/main_args.ml
+++ b/driver/main_args.ml
@@ -718,6 +718,7 @@ struct
     mk_dcombine F._dcombine;
     mk_dlive F._dlive;
     mk_dspill F._dspill;
+    mk_dsplit F._dsplit;
     mk_dinterf F._dinterf;
     mk_dprefer F._dprefer;
     mk_dalloc F._dalloc;
@@ -760,6 +761,7 @@ module Make_opttop_options (F : Opttop_options) = struct
     mk_dcombine F._dcombine;
     mk_dlive F._dlive;
     mk_dspill F._dspill;
+    mk_dsplit F._dsplit;
     mk_dinterf F._dinterf;
     mk_dprefer F._dprefer;
     mk_dalloc F._dalloc;
-- 
1.7.5.4

From c9fe22e1715d92daa21d3b46843a9a373772145c Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Wed, 21 Dec 2011 14:17:41 +0100
Subject: [PATCH 02/10] [lambda] display location when -g and -dlambda

When we have an Levent, we now display:
* the eventual file name
* whether the location is ghost
---
 bytecomp/printlambda.ml |    5 ++++-
 1 files changed, 4 insertions(+), 1 deletions(-)

diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index 9bfa099..46b165a 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -297,7 +297,10 @@ let rec lam ppf = function
        | Lev_before -> "before"
        | Lev_after _  -> "after"
        | Lev_function -> "funct-body" in
-      fprintf ppf "@[<2>(%s %i-%i@ %a)@]" kind
+      fprintf ppf "@[<2>(%s %s(%i)%s:%i-%i@ %a)@]" kind
+              ev.lev_loc.Location.loc_start.Lexing.pos_fname
+               ev.lev_loc.Location.loc_start.Lexing.pos_lnum
+              (if ev.lev_loc.Location.loc_ghost then "<ghost>" else "")
               ev.lev_loc.Location.loc_start.Lexing.pos_cnum
               ev.lev_loc.Location.loc_end.Lexing.pos_cnum
               lam expr
-- 
1.7.5.4

From 415cf662b85e1bd61c3832a8d39deefcfd6660ca Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Wed, 21 Dec 2011 14:30:32 +0100
Subject: [PATCH 03/10] [asmcomp] Clean-ups in debuginfo API

---
 asmcomp/closure.ml     |   16 +++++++-------
 asmcomp/debuginfo.ml   |   53 ++++++++++++++++++++++++++++++++++++++---------
 asmcomp/debuginfo.mli  |   32 ++++++++++++++++++++++++----
 asmcomp/emitaux.ml     |   13 +++++++----
 asmcomp/printcmm.ml    |    8 +++---
 asmcomp/printlinear.ml |    2 +-
 asmcomp/printmach.ml   |    2 +-
 7 files changed, 92 insertions(+), 34 deletions(-)

diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index 4ff4d72..b7c5215 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -440,19 +440,19 @@ let rec add_debug_info ev u =
   | Lev_after _ ->
       begin match u with
       | Udirect_apply(lbl, args, dinfo) ->
-          Udirect_apply(lbl, args, Debuginfo.from_call ev)
+          Udirect_apply(lbl, args, Debuginfo.dbg_of_call ev)
       | Ugeneric_apply(Udirect_apply(lbl, args1, dinfo1),
                        args2, dinfo2) ->
-          Ugeneric_apply(Udirect_apply(lbl, args1, Debuginfo.from_call ev),
-                         args2, Debuginfo.from_call ev)
+          Ugeneric_apply(Udirect_apply(lbl, args1, Debuginfo.dbg_of_call ev),
+                         args2, Debuginfo.dbg_of_call ev)
       | Ugeneric_apply(fn, args, dinfo) ->
-          Ugeneric_apply(fn, args, Debuginfo.from_call ev)
+          Ugeneric_apply(fn, args, Debuginfo.dbg_of_call ev)
       | Uprim(Praise, args, dinfo) ->
-          Uprim(Praise, args, Debuginfo.from_call ev)
+          Uprim(Praise, args, Debuginfo.dbg_of_call ev)
       | Uprim(p, args, dinfo) ->
-          Uprim(p, args, Debuginfo.from_call ev)
+          Uprim(p, args, Debuginfo.dbg_of_call ev)
       | Usend(kind, u1, u2, args, dinfo) ->
-          Usend(kind, u1, u2, args, Debuginfo.from_call ev)
+          Usend(kind, u1, u2, args, Debuginfo.dbg_of_call ev)
       | Usequence(u1, u2) ->
           Usequence(u1, add_debug_info ev u2)
       | _ -> u
@@ -588,7 +588,7 @@ let rec close fenv cenv = function
        Value_unknown)
   | Lprim(Praise, [Levent(arg, ev)]) ->
       let (ulam, approx) = close fenv cenv arg in
-      (Uprim(Praise, [ulam], Debuginfo.from_raise ev),
+      (Uprim(Praise, [ulam], Debuginfo.dbg_of_raise ev),
        Value_unknown)
   | Lprim(p, args) ->
       simplif_prim p (close_list_approx fenv cenv args) Debuginfo.none
diff --git a/asmcomp/debuginfo.ml b/asmcomp/debuginfo.ml
index a7124e1..cf55ff5 100644
--- a/asmcomp/debuginfo.ml
+++ b/asmcomp/debuginfo.ml
@@ -13,7 +13,11 @@
 open Lexing
 open Location
 
-type kind = Dinfo_call | Dinfo_raise
+type kind =
+  | Dinfo_none
+  | Dinfo_call
+  | Dinfo_raise
+  | Dinfo_event
 
 type t = {
   dinfo_kind: kind;
@@ -23,22 +27,41 @@ type t = {
   dinfo_char_end: int
 }
 
+type 'a expression = {
+  exp: 'a;
+  dbg: t;
+}
+
 let none = {
-  dinfo_kind = Dinfo_call;
+  dinfo_kind = Dinfo_none;
   dinfo_file = "";
   dinfo_line = 0;
   dinfo_char_start = 0;
   dinfo_char_end = 0
 }
 
-let to_string d =
-  if d == none
+let mkdbg dbg exp = {exp; dbg}
+let mk exp = mkdbg none exp
+
+let is_none d =
+  d.dinfo_kind = Dinfo_none
+
+let string_of_dbg d =
+  if is_none d
   then ""
-  else Printf.sprintf "{%s:%d,%d-%d}"
-           d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end
+  else
+    let k = match d.dinfo_kind with
+      | Dinfo_none  -> "*"
+      | Dinfo_call  -> "c"
+      | Dinfo_raise -> "r"
+      | Dinfo_event -> "e" in
+    Printf.sprintf "{%s:%d,%d-%d|%s}"
+           d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end k
 
-let from_location kind loc =
-  if loc.loc_ghost then none else
+let dbg_of_location kind loc =
+  if loc == Location.none then
+    none
+  else
   { dinfo_kind = kind;
     dinfo_file = loc.loc_start.pos_fname;
     dinfo_line = loc.loc_start.pos_lnum;
@@ -48,5 +71,15 @@ let from_location kind loc =
       then loc.loc_end.pos_cnum - loc.loc_start.pos_bol
       else loc.loc_start.pos_cnum - loc.loc_start.pos_bol }
 
-let from_call ev = from_location Dinfo_call ev.Lambda.lev_loc
-let from_raise ev = from_location Dinfo_raise ev.Lambda.lev_loc
+let from kind ev =
+  dbg_of_location kind ev.Lambda.lev_loc
+
+let dbg_of_call  = from Dinfo_call 
+let dbg_of_raise = from Dinfo_raise
+let dbg_of_event = from Dinfo_event
+
+let needs_slot_in_frame ev = match ev.dinfo_kind with
+  | Dinfo_none 
+  | Dinfo_event -> false
+  | Dinfo_raise
+  | Dinfo_call  -> true
diff --git a/asmcomp/debuginfo.mli b/asmcomp/debuginfo.mli
index c3c9c40..b86ec6c 100644
--- a/asmcomp/debuginfo.mli
+++ b/asmcomp/debuginfo.mli
@@ -10,7 +10,11 @@
 (*                                                                     *)
 (***********************************************************************)
 
-type kind = Dinfo_call | Dinfo_raise
+type kind =
+  | Dinfo_none
+  | Dinfo_call
+  | Dinfo_raise
+  | Dinfo_event
 
 type t = {
   dinfo_kind: kind;
@@ -20,11 +24,29 @@ type t = {
   dinfo_char_end: int
 }
 
+type 'a expression = {
+  exp: 'a;
+  dbg: t;
+}
+
 val none: t
 
-val to_string: t -> string
+(** Build an expression with no debuging information (ie. with the
+    value [none]) *)
+val mk: 'a -> 'a expression
+
+val mkdbg: t -> 'a -> 'a expression
+
+(** Marshalled and unmarshalled [none] value will not be physically
+    equal, so it is safer to use [is_none] instead of [(==)]. *)
+val is_none : t -> bool
+
+val string_of_dbg: t -> string
+
+val dbg_of_location: kind -> Location.t -> t
 
-val from_location: kind -> Location.t -> t
+val dbg_of_call : Lambda.lambda_event -> t
+val dbg_of_raise: Lambda.lambda_event -> t
+val dbg_of_event: Lambda.lambda_event -> t
 
-val from_call: Lambda.lambda_event -> t
-val from_raise: Lambda.lambda_event -> t
+val needs_slot_in_frame: t -> bool
diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml
index d4db78a..f33444f 100644
--- a/asmcomp/emitaux.ml
+++ b/asmcomp/emitaux.ml
@@ -147,18 +147,21 @@ let emit_frames a =
       lbl in
   let emit_frame fd =
     a.efa_label fd.fd_lbl;
-    a.efa_16 (if fd.fd_debuginfo == Debuginfo.none
-              then fd.fd_frame_size
-              else fd.fd_frame_size + 1);
+    a.efa_16 (if Debuginfo.needs_slot_in_frame fd.fd_debuginfo
+              then fd.fd_frame_size + 1
+              else fd.fd_frame_size);
     a.efa_16 (List.length fd.fd_live_offset);
     List.iter a.efa_16 fd.fd_live_offset;
     a.efa_align Arch.size_addr;
-    if fd.fd_debuginfo != Debuginfo.none then begin
+    if Debuginfo.needs_slot_in_frame fd.fd_debuginfo then begin
       let d = fd.fd_debuginfo in
       let line = min 0xFFFFF d.dinfo_line
       and char_start = min 0xFF d.dinfo_char_start
       and char_end = min 0x3FF d.dinfo_char_end
-      and kind = match d.dinfo_kind with Dinfo_call -> 0 | Dinfo_raise -> 1 in
+      and kind = match d.dinfo_kind with
+        | Dinfo_call  -> 0
+        | Dinfo_raise -> 1
+        | _ -> failwith "emit_frame" in
       let info =
         Int64.add (Int64.shift_left (Int64.of_int line) 44) (
         Int64.add (Int64.shift_left (Int64.of_int char_start) 36) (
diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml
index 364d9ea..2491bdb 100644
--- a/asmcomp/printcmm.ml
+++ b/asmcomp/printcmm.ml
@@ -51,9 +51,9 @@ let chunk = function
   | Double_u -> "float64u"
 
 let operation = function
-  | Capply(ty, d) -> "app" ^ Debuginfo.to_string d
+  | Capply(ty, d) -> "app" ^ Debuginfo.string_of_dbg d
   | Cextcall(lbl, ty, alloc, d) ->
-      Printf.sprintf "extcall \"%s\"%s" lbl (Debuginfo.to_string d)
+      Printf.sprintf "extcall \"%s\"%s" lbl (Debuginfo.string_of_dbg d)
   | Cload Word -> "load"
   | Cload c -> Printf.sprintf "load %s" (chunk c)
   | Calloc -> "alloc"
@@ -83,8 +83,8 @@ let operation = function
   | Cfloatofint -> "floatofint"
   | Cintoffloat -> "intoffloat"
   | Ccmpf c -> Printf.sprintf "%sf" (comparison c)
-  | Craise d -> "raise" ^ Debuginfo.to_string d
-  | Ccheckbound d -> "checkbound" ^ Debuginfo.to_string d
+  | Craise d -> "raise" ^ Debuginfo.string_of_dbg d
+  | Ccheckbound d -> "checkbound" ^ Debuginfo.string_of_dbg d
 
 let rec expr ppf = function
   | Cconst_int n -> fprintf ppf "%i" n
diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml
index 3737e72..3aba4f4 100644
--- a/asmcomp/printlinear.ml
+++ b/asmcomp/printlinear.ml
@@ -66,7 +66,7 @@ let instr ppf i =
       fprintf ppf "raise %a" reg i.arg.(0)
   end;
   if i.dbg != Debuginfo.none then
-    fprintf ppf " %s" (Debuginfo.to_string i.dbg)
+    fprintf ppf " %s" (Debuginfo.string_of_dbg i.dbg)
 
 let rec all_instr ppf i =
   match i.desc with
diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml
index d7d538d..b438ff0 100644
--- a/asmcomp/printmach.ml
+++ b/asmcomp/printmach.ml
@@ -183,7 +183,7 @@ let rec instr ppf i =
       fprintf ppf "raise %a" reg i.arg.(0)
   end;
   if i.dbg != Debuginfo.none then
-    fprintf ppf " %s" (Debuginfo.to_string i.dbg);
+    fprintf ppf " %s" (Debuginfo.string_of_dbg i.dbg);
   begin match i.next.desc with
     Iend -> ()
   | _ -> fprintf ppf "@,%a" instr i.next
-- 
1.7.5.4

From 263ac1bae1898716aea3359030339e1685ecc7ed Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Wed, 21 Dec 2011 15:08:01 +0100
Subject: [PATCH 04/10] [clambda] simplfiy Uclosure node

Transform a tuple into a record, and re-use it in cmmgen.
---
 asmcomp/clambda.ml  |   10 +++++++-
 asmcomp/clambda.mli |   10 +++++++-
 asmcomp/closure.ml  |   12 +++++++---
 asmcomp/cmmgen.ml   |   59 ++++++++++++++++++++++++--------------------------
 4 files changed, 52 insertions(+), 39 deletions(-)

diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml
index 5e31c3b..861c4d0 100644
--- a/asmcomp/clambda.ml
+++ b/asmcomp/clambda.ml
@@ -25,8 +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
-              * ulambda list
+  | Uclosure of ufunction list * ulambda list
   | Uoffset of ulambda * int
   | Ulet of Ident.t * ulambda * ulambda
   | Uletrec of (Ident.t * ulambda) list * ulambda
@@ -42,6 +41,13 @@ type ulambda =
   | Uassign of Ident.t * ulambda
   | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t
 
+and ufunction = {
+  label  : function_label;
+  arity  : int;
+  params : Ident.t list;
+  body   : ulambda;
+}
+
 and ulambda_switch =
   { us_index_consts: int array;
     us_actions_consts : ulambda array;
diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli
index 724490c..eccba10 100644
--- a/asmcomp/clambda.mli
+++ b/asmcomp/clambda.mli
@@ -25,8 +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
-              * ulambda list
+  | Uclosure of ufunction list * ulambda list
   | Uoffset of ulambda * int
   | Ulet of Ident.t * ulambda * ulambda
   | Uletrec of (Ident.t * ulambda) list * ulambda
@@ -42,6 +41,13 @@ type ulambda =
   | Uassign of Ident.t * ulambda
   | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t
 
+and ufunction = {
+  label  : function_label;
+  arity  : int;
+  params : Ident.t list;
+  body   : ulambda;
+}
+
 and ulambda_switch =
   { us_index_consts: int array;
     us_actions_consts: ulambda array;
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index b7c5215..2ecbf31 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -725,7 +725,10 @@ 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),
+    ({ label  = fundesc.fun_label;
+       arity  = fundesc.fun_arity;
+       params = fun_params;
+       body   = ubody },
      (id, env_pos, Value_closure(fundesc, approx))) in
   (* Translate all function definitions. *)
   let clos_info_list =
@@ -755,11 +758,12 @@ 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([f], _) as clos),
        [_, _, (Value_closure(fundesc, _) as approx)]) ->
         (* See if the function can be inlined *)
-        if lambda_smaller body (!Clflags.inline_threshold + List.length params)
-        then fundesc.fun_inline <- Some(params, body);
+        if lambda_smaller f.body
+          (!Clflags.inline_threshold + List.length f.params)
+        then fundesc.fun_inline <- Some(f.params, f.body);
         (clos, approx)
     | _ -> fatal_error "Closure.close_one_function"
 
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index ca9d2f0..77e601b 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -374,8 +374,7 @@ let make_float_alloc tag args =
 let fundecls_size fundecls =
   let sz = ref (-1) in
   List.iter
-    (fun (label, arity, params, body) ->
-      sz := !sz + 1 + (if arity = 1 then 2 else 3))
+    (fun f -> sz := !sz + 1 + (if f.arity = 1 then 2 else 3))
     fundecls;
   !sz
 
@@ -450,7 +449,7 @@ let transl_constant = function
 (* Translate constant closures *)
 
 let constant_closures =
-  ref ([] : (string * (string * int * Ident.t list * ulambda) list) list)
+  ref ([] : (string * ufunction list) list)
 
 (* Boxed integers *)
 
@@ -797,7 +796,7 @@ 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() : ufunction Queue.t)
 
 let rec transl = function
     Uvar id ->
@@ -807,10 +806,7 @@ let rec transl = function
   | Uclosure(fundecls, []) ->
       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)
-        fundecls;
+      List.iter (fun f -> Queue.add f functions) fundecls;
       Cconst_symbol lbl
   | Uclosure(fundecls, clos_vars) ->
       let block_size =
@@ -818,22 +814,22 @@ 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;
+        | f :: rem ->
+            Queue.add f functions;
             let header =
               if pos = 0
               then alloc_closure_header block_size
               else alloc_infix_header pos in
-            if arity = 1 then
+            if f.arity = 1 then
               header ::
-              Cconst_symbol label ::
+              Cconst_symbol f.label ::
               int_const 1 ::
               transl_fundecls (pos + 3) rem
             else
               header ::
-              Cconst_symbol(curry_function arity) ::
-              int_const arity ::
-              Cconst_symbol label ::
+              Cconst_symbol(curry_function f.arity) ::
+              int_const f.arity ::
+              Cconst_symbol f.label ::
               transl_fundecls (pos + 4) rem in
       Cop(Calloc, transl_fundecls 0 fundecls)
   | Uoffset(arg, offset) ->
@@ -1543,12 +1539,13 @@ module StringSet =
 
 let rec transl_all_functions already_translated cont =
   try
-    let (lbl, params, body) = Queue.take functions in
-    if StringSet.mem lbl already_translated then
+    let f = Queue.take functions in
+    if StringSet.mem f.label 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_all_functions
+        (StringSet.add f.label already_translated)
+        (transl_function f.label f.params f.body :: cont)
     end
   with Queue.Empty ->
     cont
@@ -1680,31 +1677,31 @@ and emit_boxed_int64_constant n cont =
 let emit_constant_closure symb fundecls cont =
   match fundecls with
     [] -> assert false
-  | (label, arity, params, body) :: remainder ->
+  | f1 :: remainder ->
       let rec emit_others pos = function
         [] -> cont
-      | (label, arity, params, body) :: rem ->
-          if arity = 1 then
+      | f2 :: rem ->
+          if f2.arity = 1 then
             Cint(infix_header pos) ::
-            Csymbol_address label ::
+            Csymbol_address f2.label ::
             Cint 3n ::
             emit_others (pos + 3) rem
           else
             Cint(infix_header pos) ::
-            Csymbol_address(curry_function arity) ::
-            Cint(Nativeint.of_int (arity lsl 1 + 1)) ::
-            Csymbol_address label ::
+            Csymbol_address(curry_function f2.arity) ::
+            Cint(Nativeint.of_int (f2.arity lsl 1 + 1)) ::
+            Csymbol_address f2.label ::
             emit_others (pos + 4) rem in
       Cint(closure_header (fundecls_size fundecls)) ::
       Cdefine_symbol symb ::
-      if arity = 1 then
-        Csymbol_address label ::
+      if f1.arity = 1 then
+        Csymbol_address f1.label ::
         Cint 3n ::
         emit_others 3 remainder
       else
-        Csymbol_address(curry_function arity) ::
-        Cint(Nativeint.of_int (arity lsl 1 + 1)) ::
-        Csymbol_address label ::
+        Csymbol_address(curry_function f1.arity) ::
+        Cint(Nativeint.of_int (f1.arity lsl 1 + 1)) ::
+        Csymbol_address f1.label ::
         emit_others 4 remainder
 
 (* Emit all structured constants *)
-- 
1.7.5.4

From 3b80f20641a7d49e8f6aa7ad5d6d45f241d30281 Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Wed, 21 Dec 2011 15:19:39 +0100
Subject: [PATCH 05/10] [clambda] add -dclambda option

This option dumps the produced C-lambda intermediate code.
---
 .depend                  |    7 +++
 Makefile                 |    2 +-
 asmcomp/printclambda.ml  |  132 ++++++++++++++++++++++++++++++++++++++++++++++
 asmcomp/printclambda.mli |   16 ++++++
 bytecomp/printlambda.mli |    1 +
 driver/main_args.ml      |    8 +++
 driver/main_args.mli     |    2 +
 driver/optmain.ml        |    1 +
 utils/clflags.ml         |    1 +
 utils/clflags.mli        |    1 +
 10 files changed, 170 insertions(+), 1 deletions(-)
 create mode 100644 asmcomp/printclambda.ml
 create mode 100644 asmcomp/printclambda.mli

diff --git a/.depend b/.depend
index 2c1a795..7d60b7a 100644
--- a/.depend
+++ b/.depend
@@ -498,6 +498,7 @@ asmcomp/linearize.cmi: asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi
 asmcomp/liveness.cmi: asmcomp/mach.cmi
 asmcomp/mach.cmi: asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
     asmcomp/arch.cmo
+asmcomp/printclambda.cmi: asmcomp/clambda.cmi
 asmcomp/printcmm.cmi: asmcomp/cmm.cmi
 asmcomp/printlinear.cmi: asmcomp/linearize.cmi
 asmcomp/printmach.cmi: asmcomp/reg.cmi asmcomp/mach.cmi
@@ -648,6 +649,12 @@ asmcomp/mach.cmo: asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
     asmcomp/arch.cmo asmcomp/mach.cmi
 asmcomp/mach.cmx: asmcomp/reg.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \
     asmcomp/arch.cmx asmcomp/mach.cmi
+asmcomp/printclambda.cmo: bytecomp/printlambda.cmi bytecomp/lambda.cmi \
+    typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/clambda.cmi \
+    parsing/asttypes.cmi asmcomp/printclambda.cmi
+asmcomp/printclambda.cmx: bytecomp/printlambda.cmx bytecomp/lambda.cmx \
+    typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/clambda.cmx \
+    parsing/asttypes.cmi asmcomp/printclambda.cmi
 asmcomp/printcmm.cmo: typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
     asmcomp/printcmm.cmi
 asmcomp/printcmm.cmx: typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \
diff --git a/Makefile b/Makefile
index 912259b..1255dbc 100644
--- a/Makefile
+++ b/Makefile
@@ -71,7 +71,7 @@ BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \
 ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \
   asmcomp/cmm.cmo asmcomp/printcmm.cmo \
   asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \
-  asmcomp/clambda.cmo asmcomp/compilenv.cmo \
+  asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \
   asmcomp/closure.cmo asmcomp/cmmgen.cmo \
   asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \
   asmcomp/comballoc.cmo asmcomp/liveness.cmo \
diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml
new file mode 100644
index 0000000..c0e3cae
--- /dev/null
+++ b/asmcomp/printclambda.ml
@@ -0,0 +1,132 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+
+open Format
+open Asttypes
+open Clambda
+open Debuginfo
+
+let rec pr_idents ppf = function
+  | [] -> ()
+  | h::t -> fprintf ppf "%a %a" Ident.print h pr_idents t
+
+let rec lam ppf = function
+  | Uvar id ->
+      Ident.print ppf id
+  | Uconst cst ->
+      Printlambda.structured_constant ppf cst
+  | Udirect_apply(f, largs, _) ->
+      let lams ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(apply*@ %s %a)@]" f lams largs
+  | Ugeneric_apply(lfun, largs, _) ->
+      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
+  | Uclosure(clos, fv) ->
+      let idents ppf =
+        List.iter (fprintf ppf "@ %a" Ident.print)in
+      let one_fun ppf f =
+        fprintf ppf "(fun@ %s@ %d @[<2>%a@] @[<2>%a@])"
+          f.label f.arity idents f.params lam f.body in
+      let funs ppf =
+        List.iter (fprintf ppf "@ %a" one_fun) in
+      let lams ppf =
+        List.iter (fprintf ppf "@ %a" lam) in
+      fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv
+  | Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i
+  | Ulet(id, arg, body) ->
+      let rec letbody ul = match ul with
+        | Ulet(id, arg, body) ->
+            fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg;
+            letbody body
+        | _ -> ul in
+      fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a@ %a@]" Ident.print id lam arg;
+      let expr = letbody body in
+      fprintf ppf ")@]@ %a)@]" lam expr
+  | Uletrec(id_arg_list, body) ->
+      let bindings ppf id_arg_list =
+        let spc = ref false in
+        List.iter
+          (fun (id, l) ->
+            if !spc then fprintf ppf "@ " else spc := true;
+            fprintf ppf "@[<2>%a@ %a@]" Ident.print id lam l)
+          id_arg_list in
+      fprintf ppf
+        "@[<2>(letrec@ (@[<hv 1>%a@])@ %a)@]" bindings id_arg_list lam body
+  | Uprim(prim, largs, _) ->
+      let lams ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(%a%a)@]" Printlambda.primitive prim lams largs
+  | Uswitch(larg, sw) ->
+      let switch ppf sw =
+        let spc = ref false in
+        for i = 0 to Array.length sw.us_index_consts - 1 do
+          let n = sw.us_index_consts.(i)
+          and l = sw.us_actions_consts.(i) in
+          if !spc then fprintf ppf "@ " else spc := true;
+          fprintf ppf "@[<hv 1>case int %i:@ %a@]" n lam l;
+        done;
+        for i = 0 to Array.length sw.us_index_blocks - 1 do
+          let n = sw.us_index_blocks.(i)
+          and l = sw.us_actions_blocks.(i) in
+          if !spc then fprintf ppf "@ " else spc := true;
+          fprintf ppf "@[<hv 1>case tag %i:@ %a@]" n lam l;
+        done in
+      fprintf ppf
+       "@[<1>(switch %a@ @[<v 0>%a@])@]"
+        lam larg switch sw
+  | Ustaticfail (i, ls)  ->
+      let lams ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls;
+  | Ucatch(i, vars, lbody, lhandler) ->
+      fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]"
+        lam lbody i
+        (fun ppf vars -> match vars with
+          | [] -> ()
+          | _ ->
+              List.iter
+                (fun x -> fprintf ppf " %a" Ident.print x)
+                vars)
+        vars
+        lam lhandler
+  | Utrywith(lbody, param, lhandler) ->
+      fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]"
+        lam lbody Ident.print param lam lhandler
+  | Uifthenelse(lcond, lif, lelse) ->
+      fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse
+  | Usequence(l1, l2) ->
+      fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2
+  | Uwhile(lcond, lbody) ->
+      fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody
+  | Ufor(param, lo, hi, dir, body) ->
+      fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]"
+       Ident.print param lam lo
+       (match dir with Upto -> "to" | Downto -> "downto")
+       lam hi lam body
+  | Uassign(id, expr) ->
+      fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr
+  | Usend (k, met, obj, largs, _) ->
+      let args ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      let kind =
+        if k = Lambda.Self then "self" else if k = Lambda.Cached then "cache" else "" in
+      fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs
+
+and sequence ppf ulam = match ulam with
+  | Usequence(l1, l2) ->
+      fprintf ppf "%a@ %a" sequence l1 sequence l2
+  | _ -> lam ppf ulam
+
+let clambda = lam
diff --git a/asmcomp/printclambda.mli b/asmcomp/printclambda.mli
new file mode 100644
index 0000000..ddc233a
--- /dev/null
+++ b/asmcomp/printclambda.mli
@@ -0,0 +1,16 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+open Clambda
+open Format
+
+val clambda: formatter -> ulambda -> unit
diff --git a/bytecomp/printlambda.mli b/bytecomp/printlambda.mli
index 352d6d0..5c0a7ea 100644
--- a/bytecomp/printlambda.mli
+++ b/bytecomp/printlambda.mli
@@ -18,3 +18,4 @@ open Format
 
 val structured_constant: formatter -> structured_constant -> unit
 val lambda: formatter -> lambda -> unit
+val primitive: formatter -> primitive -> unit
diff --git a/driver/main_args.ml b/driver/main_args.ml
index 0ec0ef7..d343498 100644
--- a/driver/main_args.ml
+++ b/driver/main_args.ml
@@ -310,6 +310,10 @@ let mk_dlambda f =
   "-dlambda", Arg.Unit f, " (undocumented)"
 ;;
 
+let mk_dclambda f =
+  "-dclambda", Arg.Unit f, " (undocumented)"
+;;
+
 let mk_dinstr f =
   "-dinstr", Arg.Unit f, " (undocumented)"
 ;;
@@ -503,6 +507,7 @@ module type Optcomp_options = sig
   val _dparsetree : unit -> unit
   val _drawlambda : unit -> unit
   val _dlambda : unit -> unit
+  val _dclambda : unit -> unit
   val _dcmm : unit -> unit
   val _dsel : unit -> unit
   val _dcombine : unit -> unit
@@ -545,6 +550,7 @@ module type Opttop_options = sig
   val _dparsetree : unit -> unit
   val _drawlambda : unit -> unit
   val _dlambda : unit -> unit
+  val _dclambda : unit -> unit
   val _dcmm : unit -> unit
   val _dsel : unit -> unit
   val _dcombine : unit -> unit
@@ -713,6 +719,7 @@ struct
     mk_dparsetree F._dparsetree;
     mk_drawlambda F._drawlambda;
     mk_dlambda F._dlambda;
+    mk_dclambda F._dclambda;
     mk_dcmm F._dcmm;
     mk_dsel F._dsel;
     mk_dcombine F._dcombine;
@@ -756,6 +763,7 @@ module Make_opttop_options (F : Opttop_options) = struct
 
     mk_dparsetree F._dparsetree;
     mk_drawlambda F._drawlambda;
+    mk_dclambda F._dclambda;
     mk_dcmm F._dcmm;
     mk_dsel F._dsel;
     mk_dcombine F._dcombine;
diff --git a/driver/main_args.mli b/driver/main_args.mli
index 1c4abf5..4712572 100644
--- a/driver/main_args.mli
+++ b/driver/main_args.mli
@@ -146,6 +146,7 @@ module type Optcomp_options = sig
   val _dparsetree : unit -> unit
   val _drawlambda : unit -> unit
   val _dlambda : unit -> unit
+  val _dclambda : unit -> unit
   val _dcmm : unit -> unit
   val _dsel : unit -> unit
   val _dcombine : unit -> unit
@@ -188,6 +189,7 @@ module type Opttop_options = sig
   val _dparsetree : unit -> unit
   val _drawlambda : unit -> unit
   val _dlambda : unit -> unit
+  val _dclambda : unit -> unit
   val _dcmm : unit -> unit
   val _dsel : unit -> unit
   val _dcombine : unit -> unit
diff --git a/driver/optmain.ml b/driver/optmain.ml
index 1c7352c..f46a102 100644
--- a/driver/optmain.ml
+++ b/driver/optmain.ml
@@ -146,6 +146,7 @@ module Options = Main_args.Make_optcomp_options (struct
   let _dparsetree = set dump_parsetree
   let _drawlambda = set dump_rawlambda
   let _dlambda = set dump_lambda
+  let _dclambda = set dump_clambda
   let _dcmm = set dump_cmm
   let _dsel = set dump_selection
   let _dcombine = set dump_combine
diff --git a/utils/clflags.ml b/utils/clflags.ml
index 1074d36..dd5d593 100644
--- a/utils/clflags.ml
+++ b/utils/clflags.ml
@@ -56,6 +56,7 @@ and for_package = ref (None: string option) (* -for-pack *)
 let dump_parsetree = ref false          (* -dparsetree *)
 and dump_rawlambda = ref false          (* -drawlambda *)
 and dump_lambda = ref false             (* -dlambda *)
+and dump_clambda = ref false            (* -dclambda *)
 and dump_instr = ref false              (* -dinstr *)
 
 let keep_asm_file = ref false           (* -S *)
diff --git a/utils/clflags.mli b/utils/clflags.mli
index d5357ef..b99672f 100644
--- a/utils/clflags.mli
+++ b/utils/clflags.mli
@@ -53,6 +53,7 @@ val for_package : string option ref
 val dump_parsetree : bool ref
 val dump_rawlambda : bool ref
 val dump_lambda : bool ref
+val dump_clambda : bool ref
 val dump_instr : bool ref
 val keep_asm_file : bool ref
 val optimize_for_speed : bool ref
-- 
1.7.5.4

From 0a5bb750ac1fa29500fd0075a7ea44f4d9739889 Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Wed, 21 Dec 2011 15:33:20 +0100
Subject: [PATCH 06/10] [backtraces] add CFI directives to improve backtraces

Patch from @ygrek <http://ygrek.org.ua/>
---
 Makefile                    |    1 +
 asmcomp/amd64/emit.mlp      |   29 +++++++++++++++++++++++------
 asmcomp/emitaux.ml          |   20 ++++++++++++++++++++
 asmcomp/emitaux.mli         |    4 ++++
 asmcomp/i386/emit.mlp       |   39 ++++++++++++++++++++++++++++++++++-----
 asmrun/amd64.S              |   22 ++++++++++++++++++++++
 asmrun/i386.S               |   21 +++++++++++++++++++++
 config/auto-aux/cfi.S       |    3 +++
 config/auto-aux/tryassemble |    7 +++++++
 configure                   |   17 +++++++++++++++++
 utils/config.mlbuild        |    2 ++
 utils/config.mli            |    3 +++
 utils/config.mlp            |    2 ++
 13 files changed, 159 insertions(+), 11 deletions(-)
 create mode 100644 config/auto-aux/cfi.S
 create mode 100644 config/auto-aux/tryassemble

diff --git a/Makefile b/Makefile
index 1255dbc..1b80945 100644
--- a/Makefile
+++ b/Makefile
@@ -392,6 +392,7 @@ utils/config.ml: utils/config.mlp config/Makefile
 	    -e 's|%%EXT_DLL%%|.so|' \
 	    -e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \
 	    -e 's|%%ASM%%|$(ASM)|' \
+	    -e 's|%%ASM_CFI_SUPPORTED%%|$(ASM_CFI_SUPPORTED)|' \
 	    -e 's|%%MKDLL%%|$(MKDLL)|' \
 	    -e 's|%%MKEXE%%|$(MKEXE)|' \
 	    -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \
diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
index a33a0fa..0fcdd71 100644
--- a/asmcomp/amd64/emit.mlp
+++ b/asmcomp/amd64/emit.mlp
@@ -317,11 +317,17 @@ let emit_float_test cmp neg arg lbl =
 
 (* Deallocate the stack frame before a return or tail call *)
 
-let output_epilogue () =
+let output_epilogue f =
   if frame_required() then begin
     let n = frame_size() - 8 in
-    `	addq	${emit_int n}, %rsp\n`
+    `	addq	${emit_int n}, %rsp\n`;
+    cfi_adjust_cfa_offset (-n);
+    f ();
+    (* reset CFA back cause function body may continue *)
+    cfi_adjust_cfa_offset n
   end
+  else
+    f ()
 
 (* Output the assembly code for an instruction *)
 
@@ -373,14 +379,16 @@ let emit_instr fallthrough i =
         `	{emit_call s}\n`;
         record_frame i.live i.dbg
     | Lop(Itailcall_ind) ->
-        output_epilogue();
+        output_epilogue begin fun () ->
         `	jmp	*{emit_reg i.arg.(0)}\n`
+        end
     | Lop(Itailcall_imm s) ->
         if s = !function_name then
           `	jmp	{emit_label !tailrec_entry_point}\n`
         else begin
-          output_epilogue();
+          output_epilogue begin fun () ->
           `	{emit_jump s}\n`
+          end
         end
     | Lop(Iextcall(s, alloc)) ->
         if alloc then begin
@@ -394,6 +402,7 @@ let emit_instr fallthrough i =
         if n < 0
         then `	addq	${emit_int(-n)}, %rsp\n`
         else `	subq	${emit_int(n)}, %rsp\n`;
+        cfi_adjust_cfa_offset n;
         stack_offset := !stack_offset + n
     | Lop(Iload(chunk, addr)) ->
         let dest = i.res.(0) in
@@ -536,8 +545,9 @@ let emit_instr fallthrough i =
     | Lreloadretaddr ->
         ()
     | Lreturn ->
-        output_epilogue();
+        output_epilogue begin fun () ->
         `	ret\n`
+        end
     | Llabel lbl ->
         `{emit_Llabel fallthrough lbl}:\n`
     | Lbranch lbl ->
@@ -613,12 +623,16 @@ let emit_instr fallthrough i =
     | Lsetuptrap lbl ->
         `	call	{emit_label lbl}\n`
     | Lpushtrap ->
+        cfi_adjust_cfa_offset 8;
         `	pushq	%r14\n`;
+        cfi_adjust_cfa_offset 8;
         `	movq	%rsp, %r14\n`;
         stack_offset := !stack_offset + 16
     | Lpoptrap ->
         `	popq	%r14\n`;
+        cfi_adjust_cfa_offset (-8);
         `	addq	$8, %rsp\n`;
+        cfi_adjust_cfa_offset (-8);
         stack_offset := !stack_offset - 16
     | Lraise ->
         if !Clflags.debug then begin
@@ -682,15 +696,18 @@ let fundecl fundecl =
   else
     `	.globl	{emit_symbol fundecl.fun_name}\n`;
   `{emit_symbol fundecl.fun_name}:\n`;
+  cfi_startproc ();
   if !Clflags.gprofile then emit_profile();
   if frame_required() then begin
     let n = frame_size() - 8 in
-    `	subq	${emit_int n}, %rsp\n`
+    `	subq	${emit_int n}, %rsp\n`;
+    cfi_adjust_cfa_offset n;
   end;
   `{emit_label !tailrec_entry_point}:\n`;
   emit_all true fundecl.fun_body;
   List.iter emit_call_gc !call_gc_sites;
   emit_call_bound_errors ();
+  cfi_endproc ();
   begin match Config.system with
     "linux" | "gnu" ->
       `	.type	{emit_symbol fundecl.fun_name},@function\n`;
diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml
index f33444f..be449b9 100644
--- a/asmcomp/emitaux.ml
+++ b/asmcomp/emitaux.ml
@@ -192,3 +192,23 @@ let is_generic_function name =
   List.exists
     (fun p -> isprefix p name)
     ["caml_apply"; "caml_curry"; "caml_send"; "caml_tuplify"]
+
+(* CFI directives *)
+
+let is_cfi_enabled () =
+  !Clflags.debug && Config.asm_cfi_supported
+
+let cfi_startproc () =
+  if is_cfi_enabled () then
+    emit_string "	.cfi_startproc\n"
+
+let cfi_endproc () =
+  if is_cfi_enabled () then
+    emit_string "	.cfi_endproc\n"
+
+let cfi_adjust_cfa_offset n =
+  if is_cfi_enabled () then
+  begin
+    emit_string "	.cfi_adjust_cfa_offset	"; emit_int n; emit_string "\n";
+  end
+ 
diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli
index 4f666be..4c7703b 100644
--- a/asmcomp/emitaux.mli
+++ b/asmcomp/emitaux.mli
@@ -50,3 +50,7 @@ type emit_frame_actions =
 val emit_frames: emit_frame_actions -> unit
 
 val is_generic_function: string -> bool
+
+val cfi_startproc : unit -> unit
+val cfi_endproc : unit -> unit
+val cfi_adjust_cfa_offset : int -> unit
diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp
index 881a936..167a3d6 100644
--- a/asmcomp/i386/emit.mlp
+++ b/asmcomp/i386/emit.mlp
@@ -309,9 +309,18 @@ let output_test_zero arg =
 
 (* Deallocate the stack frame before a return or tail call *)
 
-let output_epilogue () =
+let output_epilogue f =
   let n = frame_size() - 4 in
-  if n > 0 then `	addl	${emit_int n}, %esp\n`
+  if n > 0 then
+  begin
+    `	addl	${emit_int n}, %esp\n`;
+    cfi_adjust_cfa_offset (-n);
+    f ();
+    (* reset CFA back cause function body may continue *)
+    cfi_adjust_cfa_offset n
+  end
+  else
+    f ()
 
 (* Determine if the given register is the top of the floating-point stack *)
 
@@ -463,14 +472,16 @@ let emit_instr fallthrough i =
         `	call	{emit_symbol s}\n`;
         record_frame i.live i.dbg
     | Lop(Itailcall_ind) ->
-        output_epilogue();
+        output_epilogue begin fun () ->
         `	jmp	*{emit_reg i.arg.(0)}\n`
+        end
     | Lop(Itailcall_imm s) ->
         if s = !function_name then
           `	jmp	{emit_label !tailrec_entry_point}\n`
         else begin
-          output_epilogue();
+          output_epilogue begin fun () ->
           `	jmp	{emit_symbol s}\n`
+          end
         end
     | Lop(Iextcall(s, alloc)) ->
         if alloc then begin
@@ -496,6 +507,7 @@ let emit_instr fallthrough i =
         if n < 0
         then `	addl	${emit_int(-n)}, %esp\n`
         else `	subl	${emit_int(n)}, %esp\n`;
+        cfi_adjust_cfa_offset n;
         stack_offset := !stack_offset + n
     | Lop(Iload(chunk, addr)) ->
         let dest = i.res.(0) in
@@ -649,6 +661,7 @@ let emit_instr fallthrough i =
           `	fldl	{emit_reg i.arg.(0)}\n`;
         stack_offset := !stack_offset - 8;
         `	subl	$8, %esp\n`;
+        cfi_adjust_cfa_offset 8;
         `	fnstcw	4(%esp)\n`;
         `	movw	4(%esp), %ax\n`;
         `	movb    $12, %ah\n`;
@@ -663,6 +676,7 @@ let emit_instr fallthrough i =
         end;
         `	fldcw	4(%esp)\n`;
         `	addl	$8, %esp\n`;
+        cfi_adjust_cfa_offset (-8);
         stack_offset := !stack_offset + 8
     | Lop(Ispecific(Ilea addr)) ->
         `	lea	{emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n`
@@ -679,29 +693,36 @@ let emit_instr fallthrough i =
           match r with
             {loc = Reg _; typ = Float} ->
               `	subl	$8, %esp\n`;
+              cfi_adjust_cfa_offset 8;
               `	fstpl	0(%esp)\n`;
               stack_offset := !stack_offset + 8
           | {loc = Stack sl; typ = Float} ->
               let ofs = slot_offset sl 1 in
               `	pushl	{emit_int(ofs + 4)}(%esp)\n`;
               `	pushl	{emit_int(ofs + 4)}(%esp)\n`;
+              cfi_adjust_cfa_offset 8;
               stack_offset := !stack_offset + 8
           | _ ->
               `	pushl	{emit_reg r}\n`;
+              cfi_adjust_cfa_offset 4;
               stack_offset := !stack_offset + 4
         done
     | Lop(Ispecific(Ipush_int n)) ->
         `	pushl	${emit_nativeint n}\n`;
+        cfi_adjust_cfa_offset 4;
         stack_offset := !stack_offset + 4
     | Lop(Ispecific(Ipush_symbol s)) ->
         `	pushl	${emit_symbol s}\n`;
+        cfi_adjust_cfa_offset 4;
         stack_offset := !stack_offset + 4
     | Lop(Ispecific(Ipush_load addr)) ->
         `	pushl	{emit_addressing addr i.arg 0}\n`;
+        cfi_adjust_cfa_offset 4;
         stack_offset := !stack_offset + 4
     | Lop(Ispecific(Ipush_load_float addr)) ->
         `	pushl	{emit_addressing (offset_addressing addr 4) i.arg 0}\n`;
         `	pushl	{emit_addressing addr i.arg 0}\n`;
+        cfi_adjust_cfa_offset 8;
         stack_offset := !stack_offset + 8
     | Lop(Ispecific(Ifloatarithmem(double, op, addr))) ->
         if not (is_tos i.arg.(0)) then
@@ -719,8 +740,9 @@ let emit_instr fallthrough i =
     | Lreloadretaddr ->
         ()
     | Lreturn ->
-        output_epilogue();
+        output_epilogue begin fun () ->
         `	ret\n`
+        end
     | Llabel lbl ->
         `{emit_Llabel fallthrough lbl}:\n`
     | Lbranch lbl ->
@@ -784,11 +806,13 @@ let emit_instr fallthrough i =
         if trap_frame_size > 8 then
           `	subl	${emit_int (trap_frame_size - 8)}, %esp\n`;
         `	pushl	{emit_symbol "caml_exception_pointer"}\n`;
+        cfi_adjust_cfa_offset trap_frame_size;
         `	movl	%esp, {emit_symbol "caml_exception_pointer"}\n`;
         stack_offset := !stack_offset + trap_frame_size
     | Lpoptrap ->
         `	popl	{emit_symbol "caml_exception_pointer"}\n`;
         `	addl	${emit_int (trap_frame_size - 4)}, %esp\n`;
+        cfi_adjust_cfa_offset (-trap_frame_size);
         stack_offset := !stack_offset - trap_frame_size
     | Lraise ->
         if !Clflags.debug then begin
@@ -897,14 +921,19 @@ let fundecl fundecl =
   else
     `	.globl	{emit_symbol fundecl.fun_name}\n`;
   `{emit_symbol fundecl.fun_name}:\n`;
+  cfi_startproc ();
   if !Clflags.gprofile then emit_profile();
   let n = frame_size() - 4 in
   if n > 0 then
+  begin
     `	subl	${emit_int n}, %esp\n`;
+    cfi_adjust_cfa_offset n;
+  end;
   `{emit_label !tailrec_entry_point}:\n`;
   emit_all true fundecl.fun_body;
   List.iter emit_call_gc !call_gc_sites;
   emit_call_bound_errors ();
+  cfi_endproc ();
   begin match Config.system with
     "linux_elf" | "bsd_elf" | "gnu" ->
       `	.type	{emit_symbol fundecl.fun_name},@function\n`;
diff --git a/asmrun/amd64.S b/asmrun/amd64.S
index 645c2e6..589d72c 100644
--- a/asmrun/amd64.S
+++ b/asmrun/amd64.S
@@ -18,6 +18,8 @@
 
 /* PIC mode support based on contribution by Paul Stravers (see PR#4795) */
 
+#include "../config/m.h"
+
 #ifdef SYS_macosx
 
 #define G(r) _##r
@@ -47,6 +49,16 @@
 
 #endif
 
+#ifdef ASM_CFI_SUPPORTED
+#define CFI_STARTPROC .cfi_startproc
+#define CFI_ENDPROC .cfi_endproc
+#define CFI_ADJUST(n) .cfi_adjust_cfa_offset n
+#else
+#define CFI_STARTPROC
+#define CFI_ENDPROC
+#define CFI_ADJUST(n)
+#endif
+
 #ifdef __PIC__
 
 /* Position-independent operations on global variables. */
@@ -125,6 +137,7 @@
 /* Allocation */
 
 FUNCTION(G(caml_call_gc))
+        CFI_STARTPROC
         RECORD_STACK_FRAME(0)
 .Lcaml_call_gc:
     /* Build array of registers, save it into caml_gc_regs */
@@ -147,6 +160,7 @@ FUNCTION(G(caml_call_gc))
 	STORE_VAR(%r14, caml_exception_pointer)
     /* Save floating-point registers */
         subq    $(16*8), %rsp
+        CFI_ADJUST(232)
         movsd   %xmm0, 0*8(%rsp)
         movsd   %xmm1, 1*8(%rsp)
         movsd   %xmm2, 2*8(%rsp)
@@ -199,8 +213,10 @@ FUNCTION(G(caml_call_gc))
         popq    %rbp
         popq    %r12
         popq    %r13
+        CFI_ADJUST(-232)
     /* Return to caller */
         ret
+        CFI_ENDPROC
 
 FUNCTION(G(caml_alloc1))
 .Lcaml_alloc1:
@@ -277,6 +293,7 @@ FUNCTION(G(caml_c_call))
 /* Start the Caml program */
 
 FUNCTION(G(caml_start_program))
+        CFI_STARTPROC
     /* Save callee-save registers */
         pushq   %rbx
         pushq   %rbp
@@ -285,6 +302,7 @@ FUNCTION(G(caml_start_program))
         pushq   %r14
         pushq   %r15
 	subq	$8, %rsp	/* stack 16-aligned */
+        CFI_ADJUST(56)
     /* Initial entry point is G(caml_program) */
         leaq    GCALL(caml_program)(%rip), %r12
     /* Common code for caml_start_program and caml_callback* */
@@ -294,6 +312,7 @@ FUNCTION(G(caml_start_program))
         PUSH_VAR(caml_gc_regs)
         PUSH_VAR(caml_last_return_address)
         PUSH_VAR(caml_bottom_of_stack)
+        CFI_ADJUST(32)
     /* Setup alloc ptr and exception ptr */
 	LOAD_VAR(caml_young_ptr, %r15)
 	LOAD_VAR(caml_exception_pointer, %r14)
@@ -301,6 +320,7 @@ FUNCTION(G(caml_start_program))
         lea     .L108(%rip), %r13
         pushq   %r13
         pushq   %r14
+        CFI_ADJUST(16)
         movq    %rsp, %r14
     /* Call the Caml code */
         call    *%r12
@@ -308,6 +328,7 @@ FUNCTION(G(caml_start_program))
     /* Pop the exception handler */
         popq    %r14
         popq    %r12    /* dummy register */
+        CFI_ADJUST(-16)
 .L109:
     /* Update alloc ptr and exception ptr */
 	STORE_VAR(%r15,caml_young_ptr)
@@ -332,6 +353,7 @@ FUNCTION(G(caml_start_program))
     /* Mark the bucket as an exception result and return it */
         orq     $2, %rax
         jmp     .L109
+        CFI_ENDPROC
 
 /* Raise an exception from Caml */
 
diff --git a/asmrun/i386.S b/asmrun/i386.S
index 73ac467..25eadd2 100644
--- a/asmrun/i386.S
+++ b/asmrun/i386.S
@@ -16,6 +16,8 @@
 /* Asm part of the runtime system, Intel 386 processor */
 /* Must be preprocessed by cpp */
 
+#include "../config/m.h"
+
 /* Linux/BSD with ELF binaries and Solaris do not prefix identifiers with _.
    Linux/BSD with a.out binaries and NextStep do. */
 
@@ -42,6 +44,16 @@
 #define FUNCTION_ALIGN 2
 #endif
 
+#ifdef ASM_CFI_SUPPORTED
+#define CFI_STARTPROC .cfi_startproc
+#define CFI_ENDPROC .cfi_endproc
+#define CFI_ADJUST(n) .cfi_adjust_cfa_offset n
+#else
+#define CFI_STARTPROC
+#define CFI_ENDPROC
+#define CFI_ADJUST(n)
+#endif
+
 #if defined(PROFILING)
 #if defined(SYS_linux_elf) || defined(SYS_gnu)
 #define PROFILE_CAML \
@@ -89,6 +101,7 @@
 
         .align  FUNCTION_ALIGN
 G(caml_call_gc):
+        CFI_STARTPROC
         PROFILE_CAML
     /* Record lowest stack address and return address */
         movl    0(%esp), %eax
@@ -104,6 +117,7 @@ LBL(105):
         pushl   %ecx
         pushl   %ebx
         pushl   %eax
+        CFI_ADJUST(28)
         movl    %esp, G(caml_gc_regs)
         /* MacOSX note: 16-alignment of stack preserved at this point */
     /* Call the garbage collector */
@@ -116,8 +130,10 @@ LBL(105):
         popl    %esi
         popl    %edi
         popl    %ebp
+        CFI_ADJUST(-28)
     /* Return to caller */
         ret
+        CFI_ENDPROC
 
         .align  FUNCTION_ALIGN
 G(caml_alloc1):
@@ -219,12 +235,14 @@ G(caml_c_call):
         .globl  G(caml_start_program)
         .align  FUNCTION_ALIGN
 G(caml_start_program):
+        CFI_STARTPROC
         PROFILE_C
     /* Save callee-save registers */
         pushl   %ebx
         pushl   %esi
         pushl   %edi
         pushl   %ebp
+        CFI_ADJUST(16)
     /* Initial entry point is caml_program */
         movl    $ G(caml_program), %esi
     /* Common code for caml_start_program and caml_callback* */
@@ -238,6 +256,7 @@ LBL(106):
         pushl   $ LBL(108)
         ALIGN_STACK(8)
         pushl   G(caml_exception_pointer)
+        CFI_ADJUST(20)
         movl    %esp, G(caml_exception_pointer)
     /* Call the Caml code */
         call    *%esi
@@ -249,6 +268,7 @@ LBL(107):
 #else
         addl	$4, %esp
 #endif
+        CFI_ADJUST(-8)
 LBL(109):
     /* Pop the callback link, restoring the global variables */
         popl    G(caml_bottom_of_stack)
@@ -266,6 +286,7 @@ LBL(108):
     /* Mark the bucket as an exception result and return it */
         orl     $2, %eax
         jmp     LBL(109)
+        CFI_ENDPROC
 
 /* Raise an exception from Caml */
 
diff --git a/config/auto-aux/cfi.S b/config/auto-aux/cfi.S
new file mode 100644
index 0000000..e055423
--- /dev/null
+++ b/config/auto-aux/cfi.S
@@ -0,0 +1,3 @@
+.cfi_startproc
+.cfi_adjust_cfa_offset 8
+.cfi_endproc
diff --git a/config/auto-aux/tryassemble b/config/auto-aux/tryassemble
new file mode 100644
index 0000000..feffbed
--- /dev/null
+++ b/config/auto-aux/tryassemble
@@ -0,0 +1,7 @@
+#!/bin/sh
+if test "$verbose" = yes; then
+echo "tryassemble: $aspp -o tst $*" >&2
+$aspp -o tst $* || exit 100
+else
+$aspp -o tst $* 2> /dev/null || exit 100
+fi
diff --git a/configure b/configure
index 47cc203..3cfa8b4 100755
--- a/configure
+++ b/configure
@@ -1591,6 +1591,17 @@ else
   echo "LIBBFD_LINK=" >> Makefile
 fi
 
+# Check whether assembler supports CFI directives
+
+asm_cfi_supported=false
+
+export aspp
+
+if sh ./tryassemble cfi.S; then
+  echo "#define ASM_CFI_SUPPORTED" >> m.h
+  asm_cfi_supported=true
+fi
+
 # Final twiddling of compiler options to work around known bugs
 
 nativeccprofopts="$nativecccompopts"
@@ -1660,6 +1671,7 @@ echo "CMXS=$cmxs" >> Makefile
 echo "MKEXE=$mkexe" >> Makefile
 echo "MKDLL=$mksharedlib" >> Makefile
 echo "MKMAINDLL=$mkmaindll" >> Makefile
+echo "ASM_CFI_SUPPORTED=$asm_cfi_supported" >> Makefile
 
 rm -f tst hasgot.c
 rm -f ../m.h ../s.h ../Makefile
@@ -1704,6 +1716,11 @@ else
   echo "        options for linking....... $nativecclinkopts $cclibs"
   echo "        assembler ................ $as"
   echo "        preprocessed assembler ... $aspp"
+  if test "$asm_cfi_supported" = "true"; then
+  echo "        assembler supports CFI ... yes"
+  else
+  echo "        assembler supports CFI ... no"
+  fi
   echo "        native dynlink ........... $natdynlink"
   if test "$profiling" = "prof"; then
   echo "        profiling with gprof ..... supported"
diff --git a/utils/config.mlbuild b/utils/config.mlbuild
index 68a7c85..b01082f 100644
--- a/utils/config.mlbuild
+++ b/utils/config.mlbuild
@@ -88,6 +88,7 @@ let model = C.model
 let system = C.system
 
 let asm = C.asm
+let asm_cfi_supported = C.asm_cfi_supported
 
 let ext_obj = C.ext_obj
 let ext_asm = C.ext_asm
@@ -121,6 +122,7 @@ let print_config oc =
   p "model" model;
   p "system" system;
   p "asm" asm;
+  p_bool "asm_cfi_supported" asm_cfi_supported;
   p "ext_obj" ext_obj;
   p "ext_asm" ext_asm;
   p "ext_lib" ext_lib;
diff --git a/utils/config.mli b/utils/config.mli
index da39808..52152a8 100644
--- a/utils/config.mli
+++ b/utils/config.mli
@@ -98,6 +98,9 @@ val asm: string
         (* The assembler (and flags) to use for assembling
            ocamlopt-generated code. *)
 
+val asm_cfi_supported: bool
+        (* Whether assembler understands CFI directives *)
+
 val ext_obj: string
         (* Extension for object files, e.g. [.o] under Unix. *)
 val ext_asm: string
diff --git a/utils/config.mlp b/utils/config.mlp
index 4cabf90..565de17 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -77,6 +77,7 @@ let model = "%%MODEL%%"
 let system = "%%SYSTEM%%"
 
 let asm = "%%ASM%%"
+let asm_cfi_supported = %%ASM_CFI_SUPPORTED%%
 
 let ext_obj = "%%EXT_OBJ%%"
 let ext_asm = "%%EXT_ASM%%"
@@ -110,6 +111,7 @@ let print_config oc =
   p "model" model;
   p "system" system;
   p "asm" asm;
+  p_bool "asm_cfi_supported" asm_cfi_supported;
   p "ext_obj" ext_obj;
   p "ext_asm" ext_asm;
   p "ext_lib" ext_lib;
-- 
1.7.5.4

From 0b1fca48ca90c7cfcb7e417d57764f3fb0f04155 Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Wed, 21 Dec 2011 15:51:41 +0100
Subject: [PATCH 07/10] Add location to function definition in the assembly
 code

Initial patch from @till-varoqueaux (till@pps.jussieu.fr)
---
 asmcomp/amd64/emit.mlp |   28 ++++++++++++++++++++++++++++
 asmcomp/clambda.ml     |    1 +
 asmcomp/clambda.mli    |    1 +
 asmcomp/closure.ml     |    7 +++++--
 asmcomp/cmm.ml         |    3 ++-
 asmcomp/cmm.mli        |    3 ++-
 asmcomp/cmmgen.ml      |   34 +++++++++++++++++++++-------------
 asmcomp/linearize.ml   |    6 ++++--
 asmcomp/linearize.mli  |    3 ++-
 asmcomp/mach.ml        |    3 ++-
 asmcomp/mach.mli       |    3 ++-
 asmcomp/printlinear.ml |    7 ++++++-
 asmcomp/printmach.ml   |    9 +++++++--
 asmcomp/reloadgen.ml   |    3 ++-
 asmcomp/schedgen.ml    |    3 ++-
 asmcomp/selectgen.ml   |    3 ++-
 asmcomp/spill.ml       |    3 ++-
 asmcomp/split.ml       |    3 ++-
 18 files changed, 93 insertions(+), 30 deletions(-)

diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
index 0fcdd71..4aad39c 100644
--- a/asmcomp/amd64/emit.mlp
+++ b/asmcomp/amd64/emit.mlp
@@ -338,6 +338,33 @@ let tailrec_entry_point = ref 0
 
 let float_constants = ref ([] : (int * string) list)
 
+(* Emit debug information *)
+
+(* This assoc list is expected to be very short *)
+let file_pos_nums =
+  (ref [] : (string * int) list ref)
+
+(* Number of files *)
+let file_pos_num_cnt = ref 1
+
+(* We only diplay .file if the file has not been seen before. We
+   display .loc for every instruction. *)
+let emit_debug_info dbg =
+  let line = dbg.Debuginfo.dinfo_line in
+  let file_name = dbg.Debuginfo.dinfo_file in
+  if !Clflags.debug && not (Debuginfo.is_none dbg) then (
+    let file_num =
+      try List.assoc file_name !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 file_name}\n`;
+        file_pos_nums := (file_name,file_num) :: !file_pos_nums;
+        file_num in
+    `	.loc	{emit_int file_num}	{emit_int line}\n`
+  )
+
+(* Emit an instruction *)
 let emit_instr fallthrough i =
     match i.desc with
       Lend -> ()
@@ -696,6 +723,7 @@ let fundecl fundecl =
   else
     `	.globl	{emit_symbol fundecl.fun_name}\n`;
   `{emit_symbol fundecl.fun_name}:\n`;
+  emit_debug_info fundecl.fun_dbg;
   cfi_startproc ();
   if !Clflags.gprofile then emit_profile();
   if frame_required() then begin
diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml
index 861c4d0..f7c4aec 100644
--- a/asmcomp/clambda.ml
+++ b/asmcomp/clambda.ml
@@ -46,6 +46,7 @@ and ufunction = {
   arity  : int;
   params : Ident.t list;
   body   : ulambda;
+  dbg    : Debuginfo.t
 }
 
 and ulambda_switch =
diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli
index eccba10..46753c2 100644
--- a/asmcomp/clambda.mli
+++ b/asmcomp/clambda.mli
@@ -46,6 +46,7 @@ and ufunction = {
   arity  : int;
   params : Ident.t list;
   body   : ulambda;
+  dbg    : Debuginfo.t;
 }
 
 and ulambda_switch =
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index 2ecbf31..e923861 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -714,7 +714,9 @@ and close_functions fenv cenv fun_defs =
   let useless_env = ref initially_closed in
   (* Translate each function definition *)
   let clos_fundef (id, params, body, fundesc) env_pos =
-    let env_param = Ident.create "env" in
+    let dbg = match body with
+      | Levent (_,({lev_kind=Lev_function} as ev)) -> Debuginfo.dbg_of_event ev
+      | _ -> Debuginfo.none in   let env_param = Ident.create "env" in
     let cenv_fv =
       build_closure_env env_param (fv_pos - env_pos) fv in
     let cenv_body =
@@ -728,7 +730,8 @@ and close_functions fenv cenv fun_defs =
     ({ label  = fundesc.fun_label;
        arity  = fundesc.fun_arity;
        params = fun_params;
-       body   = ubody },
+       body   = ubody;
+       dbg },
      (id, env_pos, Value_closure(fundesc, approx))) in
   (* Translate all function definitions. *)
   let clos_info_list =
diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml
index 68625e2..4714696 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 1b09071..f579932 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 77e601b..81ed432 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -1523,11 +1523,12 @@ and transl_letrec bindings cont =
 
 (* Translate a function definition *)
 
-let transl_function lbl params body =
-  Cfunction {fun_name = lbl;
-             fun_args = List.map (fun id -> (id, typ_addr)) params;
-             fun_body = transl body;
-             fun_fast = !Clflags.optimize_for_speed}
+let transl_function f =
+  Cfunction {fun_name = f.label;
+             fun_args = List.map (fun id -> (id, typ_addr)) f.params;
+             fun_body = transl f.body;
+             fun_fast = !Clflags.optimize_for_speed;
+             fun_dbg  = f.dbg; }
 
 (* Translate all function definitions *)
 
@@ -1545,7 +1546,7 @@ let rec transl_all_functions already_translated cont =
     else begin
       transl_all_functions
         (StringSet.add f.label already_translated)
-        (transl_function f.label f.params f.body :: cont)
+        (transl_function f :: cont)
     end
   with Queue.Empty ->
     cont
@@ -1727,7 +1728,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);
@@ -1856,7 +1858,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
@@ -1865,7 +1868,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)
@@ -1884,7 +1888,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)
@@ -1920,7 +1925,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
@@ -1936,7 +1942,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 }
     :: intermediate_curry_functions arity (num+1)
   end
 
@@ -1989,7 +1996,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/linearize.ml b/asmcomp/linearize.ml
index 5833595..2298939 100644
--- a/asmcomp/linearize.ml
+++ b/asmcomp/linearize.ml
@@ -54,7 +54,8 @@ 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 +265,5 @@ 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 aaf0318..a04ab72 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 027550a..e25a784 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 438d15d..496f302 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/printlinear.ml b/asmcomp/printlinear.ml
index 3aba4f4..adf92a1 100644
--- a/asmcomp/printlinear.ml
+++ b/asmcomp/printlinear.ml
@@ -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 Debuginfo.is_none f.fun_dbg then
+      ""
+    else
+      " " ^ Debuginfo.string_of_dbg f.fun_dbg in
+  fprintf ppf "@[<v 2>%s:@,%a@]%s" f.fun_name all_instr f.fun_body dbg
diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml
index b438ff0..f12dc63 100644
--- a/asmcomp/printmach.ml
+++ b/asmcomp/printmach.ml
@@ -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 Debuginfo.is_none f.fun_dbg then
+      ""
+    else
+      " " ^ Debuginfo.string_of_dbg f.fun_dbg in
+  fprintf ppf "@[<v 2>%s(%a)@,%a@]%s"
+    f.fun_name regs f.fun_args instr f.fun_body dbg
 
 let phase msg ppf f =
   fprintf ppf "*** %s@.%a@." msg fundecl f
diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml
index 898c65c..0344f8d 100644
--- a/asmcomp/reloadgen.ml
+++ b/asmcomp/reloadgen.ml
@@ -134,7 +134,8 @@ 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 00762fa..4e77cf2 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 50f949a..0952324 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 968987d..9f451b4 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 9e6130d..2351094 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 }
-- 
1.7.5.4

From 91c2909919959960bb339db26149295b3615d0cb Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Wed, 21 Dec 2011 19:12:49 +0100
Subject: [PATCH 08/10] [clambda] use a record to hold location

The goal is to attach location information into each IR.

When we use -g, some Levent holding location information are inserted between each expressions in the lambda code. This patch converts Levent(dbg,exp) from the lambda-code into the following Clambda node:

    { dbg; exp = transl(exp) }

Next step is to transfer the location to C-- nodes as well.
---
 asmcomp/clambda.ml      |   12 +-
 asmcomp/clambda.mli     |   13 ++-
 asmcomp/closure.ml      |  308 ++++++++++++++++++++++++-----------------------
 asmcomp/cmmgen.ml       |   80 +++++++-----
 asmcomp/printclambda.ml |   30 +++--
 5 files changed, 240 insertions(+), 203 deletions(-)

diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml
index f7c4aec..2f0c159 100644
--- a/asmcomp/clambda.ml
+++ b/asmcomp/clambda.ml
@@ -20,16 +20,16 @@ open Lambda
 
 type function_label = string
 
-type ulambda =
+type ulambda_desc =
     Uvar of Ident.t
   | Uconst of structured_constant
-  | Udirect_apply of function_label * ulambda list * Debuginfo.t
-  | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
+  | Udirect_apply of function_label * ulambda list
+  | Ugeneric_apply of ulambda * ulambda list
   | Uclosure of ufunction list * ulambda list
   | Uoffset of ulambda * int
   | Ulet of Ident.t * ulambda * ulambda
   | Uletrec of (Ident.t * ulambda) list * ulambda
-  | Uprim of primitive * ulambda list * Debuginfo.t
+  | Uprim of primitive * ulambda list
   | Uswitch of ulambda * ulambda_switch
   | Ustaticfail of int * ulambda list
   | Ucatch of int * Ident.t list * ulambda * ulambda
@@ -39,7 +39,7 @@ type ulambda =
   | Uwhile of ulambda * ulambda
   | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda
   | Uassign of Ident.t * ulambda
-  | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t
+  | Usend of meth_kind * ulambda * ulambda * ulambda list
 
 and ufunction = {
   label  : function_label;
@@ -49,6 +49,8 @@ and ufunction = {
   dbg    : Debuginfo.t
 }
 
+and ulambda = ulambda_desc Debuginfo.expression
+
 and ulambda_switch =
   { us_index_consts: int array;
     us_actions_consts : ulambda array;
diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli
index 46753c2..8f90bb5 100644
--- a/asmcomp/clambda.mli
+++ b/asmcomp/clambda.mli
@@ -20,16 +20,16 @@ open Lambda
 
 type function_label = string
 
-type ulambda =
+type ulambda_desc =
     Uvar of Ident.t
   | Uconst of structured_constant
-  | Udirect_apply of function_label * ulambda list * Debuginfo.t
-  | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
+  | Udirect_apply of function_label * ulambda list
+  | Ugeneric_apply of ulambda * ulambda list
   | Uclosure of ufunction list * ulambda list
   | Uoffset of ulambda * int
   | Ulet of Ident.t * ulambda * ulambda
   | Uletrec of (Ident.t * ulambda) list * ulambda
-  | Uprim of primitive * ulambda list * Debuginfo.t
+  | Uprim of primitive * ulambda list
   | Uswitch of ulambda * ulambda_switch
   | Ustaticfail of int * ulambda list
   | Ucatch of int * Ident.t list * ulambda * ulambda
@@ -39,7 +39,7 @@ type ulambda =
   | Uwhile of ulambda * ulambda
   | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda
   | Uassign of Ident.t * ulambda
-  | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t
+  | Usend of meth_kind * ulambda * ulambda * ulambda list
 
 and ufunction = {
   label  : function_label;
@@ -49,6 +49,8 @@ and ufunction = {
   dbg    : Debuginfo.t;
 }
 
+and ulambda = ulambda_desc Debuginfo.expression
+
 and ulambda_switch =
   { us_index_consts: int array;
     us_actions_consts: ulambda array;
@@ -71,3 +73,4 @@ type value_approximation =
   | Value_unknown
   | Value_integer of int
   | Value_constptr of int
+
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index e923861..ed07a70 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -20,6 +20,7 @@ open Primitive
 open Lambda
 open Switch
 open Clambda
+open Debuginfo
 
 (* Auxiliaries for compiling functions *)
 
@@ -33,8 +34,8 @@ let rec split_list n l =
 let rec build_closure_env env_param pos = function
     [] -> Tbl.empty
   | id :: rem ->
-      Tbl.add id (Uprim(Pfield pos, [Uvar env_param], Debuginfo.none))
-              (build_closure_env env_param (pos+1) rem)
+      let ul = mk(Uprim(Pfield pos, [mk(Uvar env_param)])) in
+      Tbl.add id ul (build_closure_env env_param (pos+1) rem)
 
 (* Auxiliary for accessing globals.  We change the name of the global
    to the name of the corresponding asm symbol.  This is done here
@@ -42,23 +43,24 @@ let rec build_closure_env env_param pos = function
    contain the right names if the -for-pack option is active. *)
 
 let getglobal id =
-  Uprim(Pgetglobal (Ident.create_persistent (Compilenv.symbol_for_global id)),
-        [], Debuginfo.none)
+  let symb = Ident.create_persistent (Compilenv.symbol_for_global id) in
+  mk(Uprim(Pgetglobal symb, []))
+
 
 (* Check if a variable occurs in a [clambda] term. *)
 
 let occurs_var var u =
-  let rec occurs = function
+  let rec occurs ul = match ul.exp with
       Uvar v -> v = var
     | Uconst cst -> false
-    | Udirect_apply(lbl, args, _) -> List.exists occurs args
-    | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args
+    | Udirect_apply(lbl, args) -> List.exists occurs args
+    | Ugeneric_apply(funct, args) -> occurs funct || List.exists occurs args
     | Uclosure(fundecls, clos) -> List.exists occurs clos
     | Uoffset(u, ofs) -> occurs u
     | Ulet(id, def, body) -> occurs def || occurs body
     | Uletrec(decls, body) ->
         List.exists (fun (id, u) -> occurs u) decls || occurs body
-    | Uprim(p, args, _) -> List.exists occurs args
+    | Uprim(p, args) -> List.exists occurs args
     | Uswitch(arg, s) ->
         occurs arg ||
         occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks
@@ -71,7 +73,7 @@ let occurs_var var u =
     | Uwhile(cond, body) -> occurs cond || occurs body
     | Ufor(id, lo, hi, dir, body) -> occurs lo || occurs hi || occurs body
     | Uassign(id, u) -> id = var || occurs u
-    | Usend(_, met, obj, args, _) ->
+    | Usend(_, met, obj, args) ->
         occurs met || occurs obj || List.exists occurs args
   and occurs_array a =
     try
@@ -118,16 +120,16 @@ let lambda_smaller lam threshold =
   let size = ref 0 in
   let rec lambda_size lam =
     if !size > threshold then raise Exit;
-    match lam with
+    match lam.exp with
       Uvar v -> ()
     | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ |
                         Const_int32 _ | Const_int64 _ | Const_nativeint _) |
              Const_pointer _) -> incr size
     | Uconst _ ->
         raise Exit (* avoid duplication of structured constants *)
-    | Udirect_apply(fn, args, _) ->
+    | Udirect_apply(fn, args) ->
         size := !size + 4; lambda_list_size args
-    | Ugeneric_apply(fn, args, _) ->
+    | Ugeneric_apply(fn, args) ->
         size := !size + 6; lambda_size fn; lambda_list_size args
     | Uclosure(defs, vars) ->
         raise Exit (* inlining would duplicate function definitions *)
@@ -137,7 +139,7 @@ let lambda_smaller lam threshold =
         lambda_size lam; lambda_size body
     | Uletrec(bindings, body) ->
         raise Exit (* usually too large *)
-    | Uprim(prim, args, _) ->
+    | Uprim(prim, args) ->
         size := !size + prim_size prim args;
         lambda_list_size args
     | Uswitch(lam, cases) ->
@@ -162,7 +164,7 @@ let lambda_smaller lam threshold =
         size := !size + 4; lambda_size low; lambda_size high; lambda_size body
     | Uassign(id, lam) ->
         incr size;  lambda_size lam
-    | Usend(_, met, obj, args, _) ->
+    | Usend(_, met, obj, args) ->
         size := !size + 8;
         lambda_size met; lambda_size obj; lambda_list_size args
   and lambda_list_size l = List.iter lambda_size l
@@ -175,43 +177,50 @@ let lambda_smaller lam threshold =
 (* Check if a clambda term is ``pure'',
    that is without side-effects *and* not containing function definitions *)
 
-let rec is_pure_clambda = function
+let rec is_pure_clambda ul = match ul.exp with
     Uvar v -> true
   | Uconst cst -> true
   | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ |
            Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets |
-           Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false
-  | Uprim(p, args, _) -> List.for_all is_pure_clambda args
+           Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false
+  | Uprim(p, args) -> List.for_all is_pure_clambda args
   | _ -> false
 
 (* Simplify primitive operations on integers *)
 
-let make_const_int n = (Uconst(Const_base(Const_int n)), Value_integer n)
-let make_const_ptr n = (Uconst(Const_pointer n), Value_constptr n)
-let make_const_bool b = make_const_ptr(if b then 1 else 0)
+let make_const_int dbg n =
+  (mkdbg dbg (Uconst(Const_base(Const_int n))),
+   Value_integer n)
+
+let make_const_ptr dbg n =
+  (mkdbg dbg (Uconst(Const_pointer n)),
+   Value_constptr n)
 
-let simplif_prim_pure p (args, approxs) dbg =
+let make_const_bool dbg b =
+  make_const_ptr dbg (if b then 1 else 0)
+
+let simplif_prim_pure dbg p (args, approxs) =
   match approxs with
     [Value_integer x] ->
       begin match p with
-        Pidentity -> make_const_int x
-      | Pnegint -> make_const_int (-x)
-      | Poffsetint y -> make_const_int (x + y)
-      | _ -> (Uprim(p, args, dbg), Value_unknown)
+      | Pidentity    -> make_const_int dbg x
+      | Pnegint      -> make_const_int dbg (-x)
+      | Poffsetint y -> make_const_int dbg (x + y)
+      | _            -> (mkdbg dbg (Uprim(p, args)), Value_unknown)
       end
   | [Value_integer x; Value_integer y] ->
       begin match p with
-        Paddint -> make_const_int(x + y)
-      | Psubint -> make_const_int(x - y)
-      | Pmulint -> make_const_int(x * y)
-      | Pdivint when y <> 0 -> make_const_int(x / y)
-      | Pmodint when y <> 0 -> make_const_int(x mod y)
-      | Pandint -> make_const_int(x land y)
-      | Porint -> make_const_int(x lor y)
-      | Pxorint -> make_const_int(x lxor y)
-      | Plslint -> make_const_int(x lsl y)
-      | Plsrint -> make_const_int(x lsr y)
-      | Pasrint -> make_const_int(x asr y)
+      | Paddint -> make_const_int dbg (x + y)
+      | Psubint -> make_const_int dbg (x - y)
+      | Pmulint -> make_const_int dbg (x * y)
+      | Pdivint when y <> 0 -> make_const_int dbg (x / y)
+      | Pmodint when y <> 0 -> make_const_int dbg (x mod y)
+      | Pandint -> make_const_int dbg (x land y)
+      | Porint  -> make_const_int dbg (x lor y)
+      | Pxorint -> make_const_int dbg (x lxor y)
+      | Plslint -> make_const_int dbg (x lsl y)
+      | Plsrint -> make_const_int dbg (x lsr y)
+      | Pasrint -> make_const_int dbg (x asr y)
       | Pintcomp cmp ->
           let result = match cmp with
               Ceq -> x = y
@@ -220,29 +229,28 @@ let simplif_prim_pure p (args, approxs) dbg =
             | Cgt -> x > y
             | Cle -> x <= y
             | Cge -> x >= y in
-          make_const_bool result
-      | _ -> (Uprim(p, args, dbg), Value_unknown)
+          make_const_bool dbg result
+      | _ -> (mkdbg dbg (Uprim(p, args)), Value_unknown)
       end
   | [Value_constptr x] ->
       begin match p with
-        Pidentity -> make_const_ptr x
-      | Pnot -> make_const_bool(x = 0)
-      | Pisint -> make_const_bool true
-      | _ -> (Uprim(p, args, dbg), Value_unknown)
+        Pidentity -> make_const_ptr dbg x
+      | Pnot      -> make_const_bool dbg (x = 0)
+      | Pisint    -> make_const_bool dbg true
+      | _         -> (mkdbg dbg (Uprim(p, args)), Value_unknown)
       end
   | [Value_constptr x; Value_constptr y] ->
       begin match p with
-        Psequand -> make_const_bool(x <> 0 && y <> 0)
-      | Psequor  -> make_const_bool(x <> 0 || y <> 0)
-      | _ -> (Uprim(p, args, dbg), Value_unknown)
+        Psequand -> make_const_bool dbg (x <> 0 && y <> 0)
+      | Psequor  -> make_const_bool dbg (x <> 0 || y <> 0)
+      | _ -> (mkdbg dbg (Uprim(p, args)), Value_unknown)
       end
-  | _ ->
-      (Uprim(p, args, dbg), Value_unknown)
+  | _ -> (mkdbg dbg (Uprim(p, args)), Value_unknown)
 
-let simplif_prim p (args, approxs as args_approxs) dbg =
+let simplif_prim dbg p (args, approxs as args_approxs) =
   if List.for_all is_pure_clambda args
-  then simplif_prim_pure p args_approxs dbg
-  else (Uprim(p, args, dbg), Value_unknown)
+  then simplif_prim_pure dbg p args_approxs
+  else (mkdbg dbg (Uprim(p, args)), Value_unknown)
 
 (* Substitute variables in a [ulambda] term (a body of an inlined function)
    and perform some more simplifications on integer primitives.
@@ -253,21 +261,25 @@ let simplif_prim p (args, approxs as args_approxs) dbg =
    during inline expansion, and also for the translation of let rec
    over functions. *)
 
-let approx_ulam = function
+let approx_ulam ulam = match ulam.exp with
     Uconst(Const_base(Const_int n)) -> Value_integer n
   | Uconst(Const_base(Const_char c)) -> Value_integer(Char.code c)
   | Uconst(Const_pointer n) -> Value_constptr n
   | _ -> Value_unknown
 
 let rec substitute sb ulam =
-  match ulam with
+  let mk = mkdbg ulam.dbg in
+  match ulam.exp with
     Uvar v ->
-      begin try Tbl.find v sb with Not_found -> ulam end
+      begin
+        try { (Tbl.find v sb) with dbg =  ulam.dbg }
+        with Not_found -> ulam
+      end
   | Uconst cst -> ulam
-  | Udirect_apply(lbl, args, dbg) ->
-      Udirect_apply(lbl, List.map (substitute sb) args, dbg)
-  | Ugeneric_apply(fn, args, dbg) ->
-      Ugeneric_apply(substitute sb fn, List.map (substitute sb) args, dbg)
+  | Udirect_apply(lbl, args) ->
+      mk (Udirect_apply(lbl, List.map (substitute sb) args))
+  | Ugeneric_apply(fn, args) ->
+      mk (Ugeneric_apply(substitute sb fn, List.map (substitute sb) args))
   | Uclosure(defs, env) ->
       (* Question: should we rename function labels as well?  Otherwise,
          there is a risk that function labels are not globally unique.
@@ -277,66 +289,67 @@ let rec substitute sb ulam =
          - When we substitute offsets for idents bound by let rec
            in [close], case [Lletrec], we discard the original
            let rec body and use only the substituted term. *)
-      Uclosure(defs, List.map (substitute sb) env)
-  | Uoffset(u, ofs) -> Uoffset(substitute sb u, ofs)
+      mk (Uclosure(defs, List.map (substitute sb) env))
+  | Uoffset(u, ofs) -> mk (Uoffset(substitute sb u, ofs))
   | Ulet(id, u1, u2) ->
       let id' = Ident.rename id in
-      Ulet(id', substitute sb u1, substitute (Tbl.add id (Uvar id') sb) u2)
+      mk (Ulet(id', substitute sb u1, substitute (Tbl.add id (mk (Uvar id')) sb) u2))
   | Uletrec(bindings, body) ->
       let bindings1 =
         List.map (fun (id, rhs) -> (id, Ident.rename id, rhs)) bindings in
       let sb' =
         List.fold_right
-          (fun (id, id', _) s -> Tbl.add id (Uvar id') s)
+          (fun (id, id', _) s -> Tbl.add id (mk (Uvar id')) s)
           bindings1 sb in
-      Uletrec(
+      mk (Uletrec(
         List.map (fun (id, id', rhs) -> (id', substitute sb' rhs)) bindings1,
-        substitute sb' body)
-  | Uprim(p, args, dbg) ->
+        substitute sb' body))
+  | Uprim(p, args) ->
       let sargs = List.map (substitute sb) args in
-      let (res, _) = simplif_prim p (sargs, List.map approx_ulam sargs) dbg in
+      let (res, _) = simplif_prim ulam.dbg p (sargs, List.map approx_ulam sargs) in
       res
   | Uswitch(arg, sw) ->
-      Uswitch(substitute sb arg,
+      mk (Uswitch(substitute sb arg,
               { sw with
                 us_actions_consts =
                   Array.map (substitute sb) sw.us_actions_consts;
                 us_actions_blocks =
                   Array.map (substitute sb) sw.us_actions_blocks;
-               })
+               }))
   | Ustaticfail (nfail, args) ->
-      Ustaticfail (nfail, List.map (substitute sb) args)
+      mk (Ustaticfail (nfail, List.map (substitute sb) args))
   | Ucatch(nfail, ids, u1, u2) ->
-      Ucatch(nfail, ids, substitute sb u1, substitute sb u2)
+      mk (Ucatch(nfail, ids, substitute sb u1, substitute sb u2))
   | Utrywith(u1, id, u2) ->
       let id' = Ident.rename id in
-      Utrywith(substitute sb u1, id', substitute (Tbl.add id (Uvar id') sb) u2)
+      mk (Utrywith(substitute sb u1, id', substitute (Tbl.add id (mk (Uvar id')) sb) u2))
   | Uifthenelse(u1, u2, u3) ->
-      begin match substitute sb u1 with
+      let su1 = substitute sb u1 in
+      begin match su1.exp with
         Uconst(Const_pointer n) ->
           if n <> 0 then substitute sb u2 else substitute sb u3
-      | su1 ->
-          Uifthenelse(su1, substitute sb u2, substitute sb u3)
+      | _ ->
+          mk (Uifthenelse(su1, substitute sb u2, substitute sb u3))
       end
-  | Usequence(u1, u2) -> Usequence(substitute sb u1, substitute sb u2)
-  | Uwhile(u1, u2) -> Uwhile(substitute sb u1, substitute sb u2)
+  | Usequence(u1, u2) -> mk (Usequence(substitute sb u1, substitute sb u2))
+  | Uwhile(u1, u2) -> mk (Uwhile(substitute sb u1, substitute sb u2))
   | Ufor(id, u1, u2, dir, u3) ->
       let id' = Ident.rename id in
-      Ufor(id', substitute sb u1, substitute sb u2, dir,
-           substitute (Tbl.add id (Uvar id') sb) u3)
+      mk (Ufor(id', substitute sb u1, substitute sb u2, dir,
+           substitute (Tbl.add id (mk (Uvar id')) sb) u3))
   | Uassign(id, u) ->
       let id' =
         try
-          match Tbl.find id sb with Uvar i -> i | _ -> assert false
+          match Tbl.find id sb with {exp=Uvar i} -> i | _ -> assert false
         with Not_found ->
           id in
-      Uassign(id', substitute sb u)
-  | Usend(k, u1, u2, ul, dbg) ->
-      Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul, dbg)
+      mk (Uassign(id', substitute sb u))
+  | Usend(k, u1, u2, ul) ->
+      mk (Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul))
 
 (* Perform an inline expansion *)
 
-let is_simple_argument = function
+let is_simple_argument ulam = match ulam.exp with
     Uvar _ -> true
   | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ |
                       Const_int32 _ | Const_int64 _ | Const_nativeint _)) ->
@@ -344,10 +357,10 @@ let is_simple_argument = function
   | Uconst(Const_pointer _) -> true
   | _ -> false
 
-let no_effects = function
+let no_effects ulam = match ulam.exp with
     Uclosure _ -> true
   | Uconst(Const_base(Const_string _)) -> true
-  | u -> is_simple_argument u
+  | _ -> is_simple_argument ulam
 
 let rec bind_params_rec subst params args body =
   match (params, args) with
@@ -357,11 +370,14 @@ let rec bind_params_rec subst params args body =
         bind_params_rec (Tbl.add p1 a1 subst) pl al body
       else begin
         let p1' = Ident.rename p1 in
+        let mk = mkdbg body.dbg in
         let body' =
-          bind_params_rec (Tbl.add p1 (Uvar p1') subst) pl al body in
-        if occurs_var p1 body then Ulet(p1', a1, body')
-        else if no_effects a1 then body'
-        else Usequence(a1, body')
+          bind_params_rec (Tbl.add p1 (mk (Uvar p1')) subst) pl al body in
+        if occurs_var p1 body then mk (Ulet(p1', a1, body'))
+        else if no_effects a1 then
+          body'
+        else
+          mk (Usequence(a1, body'))
       end
   | (_, _) -> assert false
 
@@ -386,11 +402,12 @@ let rec is_pure = function
 (* Generate a direct application *)
 
 let direct_apply fundesc funct ufunct uargs =
+  let mk = mkdbg ufunct.dbg in
   let app_args =
     if fundesc.fun_closed then uargs else uargs @ [ufunct] in
   let app =
     match fundesc.fun_inline with
-      None -> Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none)
+      None -> mk (Udirect_apply(fundesc.fun_label, app_args))
     | Some(params, body) -> bind_params params app_args body in
   (* If ufunct can contain side-effects or function definitions,
      we must make sure that it is evaluated exactly once.
@@ -399,7 +416,7 @@ let direct_apply fundesc funct ufunct uargs =
      If the function is closed, we force the evaluation of ufunct first. *)
   if not fundesc.fun_closed || is_pure funct
   then app
-  else Usequence(ufunct, app)
+  else mk (Usequence(ufunct, app))
 
 (* Add [Value_integer] or [Value_constptr] info to the approximation
    of an application *)
@@ -414,15 +431,15 @@ let strengthen_approx appl approx =
 
 let check_constant_result lam ulam approx =
   match approx with
-    Value_integer n when is_pure lam -> make_const_int n
-  | Value_constptr n when is_pure lam -> make_const_ptr n
+    Value_integer n when is_pure lam -> make_const_int ulam.dbg n
+  | Value_constptr n when is_pure lam -> make_const_ptr ulam.dbg n
   | _ -> (ulam, approx)
 
 (* Evaluate an expression with known value for its side effects only,
    or discard it if it's pure *)
 
 let sequence_constant_expr lam ulam1 (ulam2, approx2 as res2) =
-  if is_pure lam then res2 else (Usequence(ulam1, ulam2), approx2)
+  if is_pure lam then res2 else (mk(Usequence(ulam1, ulam2)), approx2)
 
 (* Maintain the approximation of the global structure being defined *)
 
@@ -438,24 +455,14 @@ let excessive_function_nesting_depth = 5
 let rec add_debug_info ev u =
   match ev.lev_kind with
   | Lev_after _ ->
-      begin match u with
-      | Udirect_apply(lbl, args, dinfo) ->
-          Udirect_apply(lbl, args, Debuginfo.dbg_of_call ev)
-      | Ugeneric_apply(Udirect_apply(lbl, args1, dinfo1),
-                       args2, dinfo2) ->
-          Ugeneric_apply(Udirect_apply(lbl, args1, Debuginfo.dbg_of_call ev),
-                         args2, Debuginfo.dbg_of_call ev)
-      | Ugeneric_apply(fn, args, dinfo) ->
-          Ugeneric_apply(fn, args, Debuginfo.dbg_of_call ev)
-      | Uprim(Praise, args, dinfo) ->
-          Uprim(Praise, args, Debuginfo.dbg_of_call ev)
-      | Uprim(p, args, dinfo) ->
-          Uprim(p, args, Debuginfo.dbg_of_call ev)
-      | Usend(kind, u1, u2, args, dinfo) ->
-          Usend(kind, u1, u2, args, Debuginfo.dbg_of_call ev)
-      | Usequence(u1, u2) ->
-          Usequence(u1, add_debug_info ev u2)
-      | _ -> u
+      begin match u.exp with
+      | Udirect_apply _
+      | Ugeneric_apply _
+      | Uprim _
+      | Usend _ -> { u with dbg = Debuginfo.dbg_of_call ev }
+      | Usequence(u1,u2) ->
+        { u with exp = Usequence(u1, add_debug_info ev u2) }
+      | _ -> { u with dbg = Debuginfo.dbg_of_event ev }
       end
   | _ -> u
 
@@ -470,25 +477,25 @@ let close_approx_var fenv cenv id =
   let approx = try Tbl.find id fenv with Not_found -> Value_unknown in
   match approx with
     Value_integer n ->
-      make_const_int n
+      make_const_int Debuginfo.none n
   | Value_constptr n ->
-      make_const_ptr n
+      make_const_ptr Debuginfo.none n
   | approx ->
-      let subst = try Tbl.find id cenv with Not_found -> Uvar id in
+      let subst = try Tbl.find id cenv with Not_found -> mk(Uvar id) in
       (subst, approx)
 
 let close_var fenv cenv id =
   let (ulam, app) = close_approx_var fenv cenv id in ulam
 
-let rec close fenv cenv = function
+let rec close fenv cenv lam = match lam with
     Lvar id ->
       close_approx_var fenv cenv id
   | Lconst cst ->
       begin match cst with
-        Const_base(Const_int n) -> (Uconst cst, Value_integer n)
-      | Const_base(Const_char c) -> (Uconst cst, Value_integer(Char.code c))
-      | Const_pointer n -> (Uconst cst, Value_constptr n)
-      | _ -> (Uconst cst, Value_unknown)
+        Const_base(Const_int n) -> (mk (Uconst cst), Value_integer n)
+      | Const_base(Const_char c) -> (mk (Uconst cst), Value_integer(Char.code c))
+      | Const_pointer n -> (mk (Uconst cst), Value_constptr n)
+      | _ -> (mk (Uconst cst), Value_unknown)
       end
   | Lfunction(kind, params, body) as funct ->
       close_one_function fenv cenv (Ident.create "fun") funct
@@ -496,7 +503,7 @@ let rec close fenv cenv = function
       let nargs = List.length args in
       begin match (close fenv cenv funct, close_list fenv cenv args) with
         ((ufunct, Value_closure(fundesc, approx_res)),
-         [Uprim(Pmakeblock(_, _), uargs, _)])
+         [{exp=Uprim(Pmakeblock(_, _), uargs)}])
         when List.length uargs = - fundesc.fun_arity ->
           let app = direct_apply fundesc funct ufunct uargs in
           (app, strengthen_approx app approx_res)
@@ -507,29 +514,28 @@ let rec close fenv cenv = function
       | ((ufunct, Value_closure(fundesc, approx_res)), uargs)
         when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity ->
           let (first_args, rem_args) = split_list fundesc.fun_arity uargs in
-          (Ugeneric_apply(direct_apply fundesc funct ufunct first_args,
-                          rem_args, Debuginfo.none),
+          (mk (Ugeneric_apply(direct_apply fundesc funct ufunct first_args, rem_args)),
            Value_unknown)
       | ((ufunct, _), uargs) ->
-          (Ugeneric_apply(ufunct, uargs, Debuginfo.none), Value_unknown)
+          (mk (Ugeneric_apply(ufunct, uargs)), Value_unknown)
       end
   | Lsend(kind, met, obj, args, _) ->
       let (umet, _) = close fenv cenv met in
       let (uobj, _) = close fenv cenv obj in
-      (Usend(kind, umet, uobj, close_list fenv cenv args, Debuginfo.none),
+      (mk (Usend(kind, umet, uobj, close_list fenv cenv args)),
        Value_unknown)
   | Llet(str, id, lam, body) ->
       let (ulam, alam) = close_named fenv cenv id lam in
       begin match (str, alam) with
         (Variable, _) ->
           let (ubody, abody) = close fenv cenv body in
-          (Ulet(id, ulam, ubody), abody)
+          mk (Ulet(id, ulam, ubody)), abody
       | (_, (Value_integer _ | Value_constptr _))
         when str = Alias || is_pure lam ->
           close (Tbl.add id alam fenv) cenv body
       | (_, _) ->
           let (ubody, abody) = close (Tbl.add id alam fenv) cenv body in
-          (Ulet(id, ulam, ubody), abody)
+          mk (Ulet(id, ulam, ubody)), abody
       end
   | Lletrec(defs, body) ->
       if List.for_all
@@ -547,9 +553,9 @@ let rec close fenv cenv = function
         let sb =
           List.fold_right
             (fun (id, pos, approx) sb ->
-              Tbl.add id (Uoffset(Uvar clos_ident, pos)) sb)
+              Tbl.add id (mk (Uoffset(mk (Uvar clos_ident), pos))) sb)
             infos Tbl.empty in
-        (Ulet(clos_ident, clos, substitute sb ubody),
+        (mk (Ulet(clos_ident, clos, substitute sb ubody)),
          approx)
       end else begin
         (* General case: recursive definition of values *)
@@ -561,15 +567,15 @@ let rec close fenv cenv = function
             ((id, ulam) :: udefs, Tbl.add id approx fenv_body) in
         let (udefs, fenv_body) = clos_defs defs in
         let (ubody, approx) = close fenv_body cenv body in
-        (Uletrec(udefs, ubody), approx)
+        mk (Uletrec(udefs, ubody)), approx
       end
-  | Lprim(Pgetglobal id, []) as lam ->
+  | Lprim(Pgetglobal id, []) ->
       check_constant_result lam
                             (getglobal id)
                             (Compilenv.global_approx id)
   | Lprim(Pmakeblock(tag, mut) as prim, lams) ->
       let (ulams, approxs) = List.split (List.map (close fenv cenv) lams) in
-      (Uprim(prim, ulams, Debuginfo.none),
+      (mk (Uprim(prim, ulams)),
        begin match mut with
            Immutable -> Value_tuple(Array.of_list approxs)
          | Mutable -> Value_unknown
@@ -580,18 +586,17 @@ let rec close fenv cenv = function
         match approx with
           Value_tuple a when n < Array.length a -> a.(n)
         | _ -> Value_unknown in
-      check_constant_result lam (Uprim(Pfield n, [ulam], Debuginfo.none)) fieldapprox
+      check_constant_result lam (mk (Uprim(Pfield n, [ulam]))) fieldapprox
   | Lprim(Psetfield(n, _), [Lprim(Pgetglobal id, []); lam]) ->
       let (ulam, approx) = close fenv cenv lam in
       (!global_approx).(n) <- approx;
-      (Uprim(Psetfield(n, false), [getglobal id; ulam], Debuginfo.none),
-       Value_unknown)
+      (mk (Uprim(Psetfield(n, false), [getglobal id; ulam])), Value_unknown)
   | Lprim(Praise, [Levent(arg, ev)]) ->
       let (ulam, approx) = close fenv cenv arg in
-      (Uprim(Praise, [ulam], Debuginfo.dbg_of_raise ev),
+      (mkdbg (dbg_of_raise ev)(Uprim(Praise, [ulam])),
        Value_unknown)
   | Lprim(p, args) ->
-      simplif_prim p (close_list_approx fenv cenv args) Debuginfo.none
+      simplif_prim Debuginfo.none p (close_list_approx fenv cenv args)
   | Lswitch(arg, sw) ->
 (* NB: failaction might get copied, thus it should be some Lstaticraise *)
       let (uarg, _) = close fenv cenv arg in
@@ -599,22 +604,22 @@ let rec close fenv cenv = function
         close_switch fenv cenv sw.sw_consts sw.sw_numconsts sw.sw_failaction
       and block_index, block_actions =
         close_switch fenv cenv sw.sw_blocks sw.sw_numblocks sw.sw_failaction in
-      (Uswitch(uarg,
+      (mk (Uswitch(uarg,
                {us_index_consts = const_index;
                 us_actions_consts = const_actions;
                 us_index_blocks = block_index;
-                us_actions_blocks = block_actions}),
+                us_actions_blocks = block_actions})),
        Value_unknown)
   | Lstaticraise (i, args) ->
-      (Ustaticfail (i, close_list fenv cenv args), Value_unknown)
+      (mk (Ustaticfail (i, close_list fenv cenv args)), Value_unknown)
   | Lstaticcatch(body, (i, vars), handler) ->
       let (ubody, _) = close fenv cenv body in
       let (uhandler, _) = close fenv cenv handler in
-      (Ucatch(i, vars, ubody, uhandler), Value_unknown)
+      (mk (Ucatch(i, vars, ubody, uhandler)), Value_unknown)
   | Ltrywith(body, id, handler) ->
       let (ubody, _) = close fenv cenv body in
       let (uhandler, _) = close fenv cenv handler in
-      (Utrywith(ubody, id, uhandler), Value_unknown)
+      (mk (Utrywith(ubody, id, uhandler)), Value_unknown)
   | Lifthenelse(arg, ifso, ifnot) ->
       begin match close fenv cenv arg with
         (uarg, Value_constptr n) ->
@@ -623,24 +628,24 @@ let rec close fenv cenv = function
       | (uarg, _ ) ->
           let (uifso, _) = close fenv cenv ifso in
           let (uifnot, _) = close fenv cenv ifnot in
-          (Uifthenelse(uarg, uifso, uifnot), Value_unknown)
+          (mk (Uifthenelse(uarg, uifso, uifnot)), Value_unknown)
       end
   | Lsequence(lam1, lam2) ->
       let (ulam1, _) = close fenv cenv lam1 in
       let (ulam2, approx) = close fenv cenv lam2 in
-      (Usequence(ulam1, ulam2), approx)
+      mk (Usequence(ulam1, ulam2)), approx
   | Lwhile(cond, body) ->
       let (ucond, _) = close fenv cenv cond in
       let (ubody, _) = close fenv cenv body in
-      (Uwhile(ucond, ubody), Value_unknown)
+      (mk (Uwhile(ucond, ubody)), Value_unknown)
   | Lfor(id, lo, hi, dir, body) ->
       let (ulo, _) = close fenv cenv lo in
       let (uhi, _) = close fenv cenv hi in
       let (ubody, _) = close fenv cenv body in
-      (Ufor(id, ulo, uhi, dir, ubody), Value_unknown)
+      (mk (Ufor(id, ulo, uhi, dir, ubody)), Value_unknown)
   | Lassign(id, lam) ->
       let (ulam, _) = close fenv cenv lam in
-      (Uassign(id, ulam), Value_unknown)
+      (mk (Uassign(id, ulam)), Value_unknown)
   | Levent(lam, ev) ->
       let (ulam, approx) = close fenv cenv lam in
       (add_debug_info ev ulam, approx)
@@ -716,13 +721,14 @@ and close_functions fenv cenv fun_defs =
   let clos_fundef (id, params, body, fundesc) env_pos =
     let dbg = match body with
       | Levent (_,({lev_kind=Lev_function} as ev)) -> Debuginfo.dbg_of_event ev
-      | _ -> Debuginfo.none in   let env_param = Ident.create "env" in
+      | _ -> Debuginfo.none in
+    let env_param = Ident.create "env" in
     let cenv_fv =
       build_closure_env env_param (fv_pos - env_pos) fv in
     let cenv_body =
       List.fold_right2
         (fun (id, params, arity, body) pos env ->
-          Tbl.add id (Uoffset(Uvar env_param, pos - env_pos)) env)
+          Tbl.add id (mk(Uoffset(mk(Uvar env_param), pos - env_pos))) env)
         uncurried_defs clos_offsets cenv_fv in
     let (ubody, approx) = close fenv_rec cenv_body body in
     if !useless_env && occurs_var env_param ubody then useless_env := false;
@@ -731,7 +737,7 @@ and close_functions fenv cenv fun_defs =
        arity  = fundesc.fun_arity;
        params = fun_params;
        body   = ubody;
-       dbg },
+       Clambda.dbg },
      (id, env_pos, Value_closure(fundesc, approx))) in
   (* Translate all function definitions. *)
   let clos_info_list =
@@ -755,13 +761,13 @@ and close_functions fenv cenv fun_defs =
   (* Return the Uclosure node and the list of all identifiers defined,
      with offsets and approximations. *)
   let (clos, infos) = List.split clos_info_list in
-  (Uclosure(clos, List.map (close_var fenv cenv) fv), infos)
+  mk(Uclosure(clos, List.map (close_var fenv cenv) fv)), infos
 
 (* Same, for one non-recursive function *)
 
 and close_one_function fenv cenv id funct =
   match close_functions fenv cenv [id, funct] with
-      ((Uclosure([f], _) as clos),
+      (({exp=Uclosure([f], _)} as clos),
        [_, _, (Value_closure(fundesc, _) as approx)]) ->
         (* See if the function can be inlined *)
         if lambda_smaller f.body
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 81ed432..2ee2ec6 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -21,9 +21,11 @@ open Primitive
 open Types
 open Lambda
 open Clambda
+open Debuginfo
 open Cmm
 open Cmx_format
 
+
 (* Local binding of complex expressions *)
 
 let bind name arg fn =
@@ -297,16 +299,20 @@ let array_indexing log2size ptr ofs =
 
 let addr_array_ref arr ofs =
   Cop(Cload Word, [array_indexing log2_size_addr arr ofs])
+
 let unboxed_float_array_ref arr ofs =
   Cop(Cload Double_u, [array_indexing log2_size_float arr ofs])
+
 let float_array_ref arr ofs =
   box_float(unboxed_float_array_ref arr ofs)
 
 let addr_array_set arr ofs newval =
   Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none),
       [array_indexing log2_size_addr arr ofs; newval])
+
 let int_array_set arr ofs newval =
   Cop(Cstore Word, [array_indexing log2_size_addr arr ofs; newval])
+
 let float_array_set arr ofs newval =
   Cop(Cstore Double_u, [array_indexing log2_size_float arr ofs; newval])
 
@@ -382,16 +388,17 @@ type rhs_kind =
   | RHS_block of int
   | RHS_nonrec
 ;;
-let rec expr_size = function
+let rec expr_size ulam =
+  match ulam.exp with
   | Uclosure(fundecls, clos_vars) ->
       RHS_block (fundecls_size fundecls + List.length clos_vars)
   | Ulet(id, exp, body) ->
       expr_size body
   | Uletrec(bindings, body) ->
       expr_size body
-  | Uprim(Pmakeblock(tag, mut), args, _) ->
+  | Uprim(Pmakeblock(tag, mut), args) ->
       RHS_block (List.length args)
-  | Uprim(Pmakearray(Paddrarray | Pintarray), args, _) ->
+  | Uprim(Pmakearray(Paddrarray | Pintarray), args) ->
       RHS_block (List.length args)
   | Usequence(exp, exp') ->
       expr_size exp'
@@ -680,6 +687,7 @@ let make_switch_gen arg cases acts =
     let new_act = store.Switch.act_store act in
     new_cases.(i) <- new_act
   done ;
+
   Cswitch
     (arg, new_cases,
      Array.map
@@ -724,10 +732,11 @@ type unboxed_number_kind =
   | Boxed_float
   | Boxed_integer of boxed_integer
 
-let is_unboxed_number = function
+let is_unboxed_number ulam =
+  match ulam.exp with
     Uconst(Const_base(Const_float f)) ->
       Boxed_float
-  | Uprim(p, _, _) ->
+  | Uprim(p, _) ->
       begin match simplif_primitive p with
           Pccall p -> if p.prim_native_float then Boxed_float else No_unboxing
         | Pfloatfield _ -> Boxed_float
@@ -798,7 +807,10 @@ let subst_boxed_number unbox_fn boxed_id unboxed_id exp =
 
 let functions = (Queue.create() : ufunction Queue.t)
 
-let rec transl = function
+let rec transl ulam =
+  let dbg = ulam.dbg in
+  let mk = mkdbg dbg in
+  match ulam.exp with
     Uvar id ->
       Cvar id
   | Uconst sc ->
@@ -834,17 +846,17 @@ let rec transl = function
       Cop(Calloc, transl_fundecls 0 fundecls)
   | Uoffset(arg, offset) ->
       field_address (transl arg) offset
-  | Udirect_apply(lbl, args, dbg) ->
+  | Udirect_apply(lbl, args) ->
       Cop(Capply(typ_addr, dbg), Cconst_symbol lbl :: List.map transl args)
-  | Ugeneric_apply(clos, [arg], dbg) ->
+  | Ugeneric_apply(clos, [arg]) ->
       bind "fun" (transl clos) (fun clos ->
         Cop(Capply(typ_addr, dbg), [get_field clos 0; transl arg; clos]))
-  | Ugeneric_apply(clos, args, dbg) ->
+  | Ugeneric_apply(clos, args) ->
       let arity = List.length args in
       let cargs = Cconst_symbol(apply_function arity) ::
         List.map transl (args @ [clos]) in
       Cop(Capply(typ_addr, dbg), cargs)
-  | Usend(kind, met, obj, args, dbg) ->
+  | Usend(kind, met, obj, args) ->
       let call_met obj args clos =
         if args = [] then
           Cop(Capply(typ_addr, dbg), [get_field clos 0;obj;clos])
@@ -878,7 +890,7 @@ let rec transl = function
       transl_letrec bindings (transl body)
 
   (* Primitives *)
-  | Uprim(prim, args, dbg) ->
+  | Uprim(prim, args) ->
       begin match (simplif_primitive prim, args) with
         (Pgetglobal id, []) ->
           Cconst_symbol (Ident.name id)
@@ -972,25 +984,25 @@ let rec transl = function
       Ccatch(nfail, ids, transl body, transl handler)
   | Utrywith(body, exn, handler) ->
       Ctrywith(transl body, exn, transl handler)
-  | Uifthenelse(Uprim(Pnot, [arg], _), ifso, ifnot) ->
-      transl (Uifthenelse(arg, ifnot, ifso))
-  | Uifthenelse(cond, ifso, Ustaticfail (nfail, [])) ->
+  | Uifthenelse({exp=Uprim(Pnot, [arg])}, ifso, ifnot) ->
+      transl (mk(Uifthenelse(arg, ifnot, ifso)))
+  | Uifthenelse(cond, ifso, {exp=Ustaticfail (nfail, [])}) ->
       exit_if_false cond (transl ifso) nfail
-  | Uifthenelse(cond, Ustaticfail (nfail, []), ifnot) ->
+  | Uifthenelse(cond, {exp=Ustaticfail (nfail, [])}, ifnot) ->
       exit_if_true cond nfail (transl ifnot)
-  | Uifthenelse(Uprim(Psequand, _, _) as cond, ifso, ifnot) ->
+  | Uifthenelse({exp=Uprim(Psequand, _)} as cond, ifso, ifnot) ->
       let raise_num = next_raise_count () in
       make_catch
         raise_num
         (exit_if_false cond (transl ifso) raise_num)
         (transl ifnot)
-  | Uifthenelse(Uprim(Psequor, _, _) as cond, ifso, ifnot) ->
+  | Uifthenelse({exp=Uprim(Psequor, _)} as cond, ifso, ifnot) ->
       let raise_num = next_raise_count () in
       make_catch
         raise_num
         (exit_if_true cond raise_num (transl ifnot))
         (transl ifso)
-  | Uifthenelse (Uifthenelse (cond, condso, condnot), ifso, ifnot) ->
+  | Uifthenelse ({exp=Uifthenelse (cond, condso, condnot)}, ifso, ifnot) ->
       let num_true = next_raise_count () in
       make_catch
         num_true
@@ -1066,7 +1078,7 @@ and transl_prim_1 p arg dbg =
       if no_overflow_lsl n then
         add_const (transl arg) (n lsl 1)
       else
-        transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n))) Debuginfo.none
+        transl_prim_2 Paddint arg (mk(Uconst (Const_base(Const_int n)))) Debuginfo.none
   | Poffsetref n ->
       return_unit
         (bind "ref" (transl arg) (fun arg ->
@@ -1363,20 +1375,22 @@ and transl_prim_3 p arg1 arg2 arg3 dbg =
   | _ ->
     fatal_error "Cmmgen.transl_prim_3"
 
-and transl_unbox_float = function
+and transl_unbox_float ulam =
+  match ulam.exp with
     Uconst(Const_base(Const_float f)) -> Cconst_float f
-  | exp -> unbox_float(transl exp)
+  | _ -> unbox_float(transl ulam)
 
-and transl_unbox_int bi = function
+and transl_unbox_int bi ulam =
+  match ulam.exp with
     Uconst(Const_base(Const_int32 n)) ->
       Cconst_natint (Nativeint.of_int32 n)
   | Uconst(Const_base(Const_nativeint n)) ->
       Cconst_natint n
   | Uconst(Const_base(Const_int64 n)) ->
       assert (size_int = 8); Cconst_natint (Int64.to_nativeint n)
-  | Uprim(Pbintofint bi', [Uconst(Const_base(Const_int i))], _) when bi = bi' ->
+  | Uprim(Pbintofint bi', [{exp=Uconst(Const_base(Const_int i))}]) when bi = bi' ->
       Cconst_int i
-  | exp -> unbox_int bi (transl exp)
+  | _ -> unbox_int bi (transl ulam)
 
 and transl_unbox_let box_fn unbox_fn transl_unbox_fn id exp body =
   let unboxed_id = Ident.create (Ident.name id) in
@@ -1406,12 +1420,12 @@ and make_catch2 mk_body handler = match handler with
       handler
 
 and exit_if_true cond nfail otherwise =
-  match cond with
+  match cond.exp with
   | Uconst (Const_pointer 0) -> otherwise
   | Uconst (Const_pointer 1) -> Cexit (nfail,[])
-  | Uprim(Psequor, [arg1; arg2], _) ->
+  | Uprim(Psequor, [arg1; arg2]) ->
       exit_if_true arg1 nfail (exit_if_true arg2 nfail otherwise)
-  | Uprim(Psequand, _, _) ->
+  | Uprim(Psequand, _) ->
       begin match otherwise with
       | Cexit (raise_num,[]) ->
           exit_if_false cond (Cexit (nfail,[])) raise_num
@@ -1422,7 +1436,7 @@ and exit_if_true cond nfail otherwise =
             (exit_if_false cond (Cexit (nfail,[])) raise_num)
             otherwise
       end
-  | Uprim(Pnot, [arg], _) ->
+  | Uprim(Pnot, [arg]) ->
       exit_if_false arg otherwise nfail
   | Uifthenelse (cond, ifso, ifnot) ->
       make_catch2
@@ -1436,12 +1450,12 @@ and exit_if_true cond nfail otherwise =
       Cifthenelse(test_bool(transl cond), Cexit (nfail, []), otherwise)
 
 and exit_if_false cond otherwise nfail =
-  match cond with
+  match cond.exp with
   | Uconst (Const_pointer 0) -> Cexit (nfail,[])
   | Uconst (Const_pointer 1) -> otherwise
-  | Uprim(Psequand, [arg1; arg2], _) ->
+  | Uprim(Psequand, [arg1; arg2]) ->
       exit_if_false arg1 (exit_if_false arg2 otherwise nfail) nfail
-  | Uprim(Psequor, _, _) ->
+  | Uprim(Psequor, _) ->
       begin match otherwise with
       | Cexit (raise_num,[]) ->
           exit_if_true cond raise_num (Cexit (nfail,[]))
@@ -1452,7 +1466,7 @@ and exit_if_false cond otherwise nfail =
             (exit_if_true cond raise_num (Cexit (nfail,[])))
             otherwise
       end
-  | Uprim(Pnot, [arg], _) ->
+  | Uprim(Pnot, [arg]) ->
       exit_if_true arg nfail otherwise
   | Uifthenelse (cond, ifso, ifnot) ->
       make_catch2
@@ -1528,7 +1542,7 @@ let transl_function f =
              fun_args = List.map (fun id -> (id, typ_addr)) f.params;
              fun_body = transl f.body;
              fun_fast = !Clflags.optimize_for_speed;
-             fun_dbg  = f.dbg; }
+             fun_dbg  = f.Clambda.dbg; }
 
 (* Translate all function definitions *)
 
diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml
index c0e3cae..ad96ae0 100644
--- a/asmcomp/printclambda.ml
+++ b/asmcomp/printclambda.ml
@@ -20,16 +20,16 @@ let rec pr_idents ppf = function
   | [] -> ()
   | h::t -> fprintf ppf "%a %a" Ident.print h pr_idents t
 
-let rec lam ppf = function
+let rec lam_desc ppf = function
   | Uvar id ->
       Ident.print ppf id
   | Uconst cst ->
       Printlambda.structured_constant ppf cst
-  | Udirect_apply(f, largs, _) ->
+  | Udirect_apply(f, largs) ->
       let lams ppf largs =
         List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
       fprintf ppf "@[<2>(apply*@ %s %a)@]" f lams largs
-  | Ugeneric_apply(lfun, largs, _) ->
+  | Ugeneric_apply(lfun, largs) ->
       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
@@ -37,7 +37,10 @@ let rec lam ppf = function
       let idents ppf =
         List.iter (fprintf ppf "@ %a" Ident.print)in
       let one_fun ppf f =
-        fprintf ppf "(fun@ %s@ %d @[<2>%a@] @[<2>%a@])"
+        fprintf ppf "(";
+        if not (is_none f.Clambda.dbg) then
+          fprintf ppf "%s@ " (string_of_dbg f.Clambda.dbg);
+        fprintf ppf "fun@ %s@ %d @[<2>%a@] @[<2>%a@])"
           f.label f.arity idents f.params lam f.body in
       let funs ppf =
         List.iter (fprintf ppf "@ %a" one_fun) in
@@ -46,7 +49,7 @@ let rec lam ppf = function
       fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv
   | Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i
   | Ulet(id, arg, body) ->
-      let rec letbody ul = match ul with
+      let rec letbody ul = match ul.exp with
         | Ulet(id, arg, body) ->
             fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg;
             letbody body
@@ -64,7 +67,7 @@ let rec lam ppf = function
           id_arg_list in
       fprintf ppf
         "@[<2>(letrec@ (@[<hv 1>%a@])@ %a)@]" bindings id_arg_list lam body
-  | Uprim(prim, largs, _) ->
+  | Uprim(prim, largs) ->
       let lams ppf largs =
         List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
       fprintf ppf "@[<2>(%a%a)@]" Printlambda.primitive prim lams largs
@@ -117,16 +120,25 @@ let rec lam ppf = function
        lam hi lam body
   | Uassign(id, expr) ->
       fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr
-  | Usend (k, met, obj, largs, _) ->
+  | Usend (k, met, obj, largs) ->
       let args ppf largs =
         List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
       let kind =
         if k = Lambda.Self then "self" else if k = Lambda.Cached then "cache" else "" in
       fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs
 
-and sequence ppf ulam = match ulam with
+and sequence ppf ulam = match ulam.exp with
   | Usequence(l1, l2) ->
       fprintf ppf "%a@ %a" sequence l1 sequence l2
-  | _ -> lam ppf ulam
+  | _ ->
+      lam ppf ulam
+
+and lam ppf ulam =
+  if is_none ulam.dbg then
+    lam_desc ppf ulam.exp
+  else
+    fprintf ppf "@[<2>(%s %a)@]"
+      (string_of_dbg ulam.dbg)
+      lam_desc ulam.exp
 
 let clambda = lam
-- 
1.7.5.4

From de6fa43351df9867061e302c6f21751dcb703005 Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas@gazagnaire.org>
Date: Thu, 22 Dec 2011 11:23:59 +0100
Subject: [PATCH 09/10] [C--] propagate location through C--

Change the type of C-- nodes to be a record holding the location information and the node description (of C-- type).

This was the nig missing piece for location propagation, So now, location information goes from the front-end to the linear code.

The remaining bit is to emit the location information in the assembly.
---
 asmcomp/amd64/selection.ml |   64 ++--
 asmcomp/cmm.ml             |   13 +-
 asmcomp/cmm.mli            |   14 +-
 asmcomp/cmmgen.ml          | 1200 ++++++++++++++++++++++++--------------------
 asmcomp/printcmm.ml        |   58 ++-
 asmcomp/selectgen.ml       |  282 +++++------
 asmcomp/selectgen.mli      |   15 +-
 7 files changed, 880 insertions(+), 766 deletions(-)

diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml
index 4921e51..4985ab3 100644
--- a/asmcomp/amd64/selection.ml
+++ b/asmcomp/amd64/selection.ml
@@ -17,6 +17,7 @@
 open Misc
 open Arch
 open Proc
+open Debuginfo
 open Cmm
 open Reg
 open Mach
@@ -31,26 +32,26 @@ type addressing_expr =
   | Ascaledadd of expression * expression * int
 
 let rec select_addr exp =
-  match exp with
+  match exp.exp with
     Cconst_symbol s when not !Clflags.dlcode ->
       (Asymbol s, 0)
-  | Cop((Caddi | Cadda), [arg; Cconst_int m]) ->
+  | Cop((Caddi | Cadda), [arg; {exp=Cconst_int m}]) ->
       let (a, n) = select_addr arg in (a, n + m)
-  | Cop((Csubi | Csuba), [arg; Cconst_int m]) ->
+  | Cop((Csubi | Csuba), [arg; {exp=Cconst_int m}]) ->
       let (a, n) = select_addr arg in (a, n - m)
-  | Cop((Caddi | Cadda), [Cconst_int m; arg]) ->
+  | Cop((Caddi | Cadda), [{exp=Cconst_int m}; arg]) ->
       let (a, n) = select_addr arg in (a, n + m)
-  | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)]) ->
+  | Cop(Clsl, [arg; {exp=Cconst_int(1|2|3 as shift)}]) ->
       begin match select_addr arg with
         (Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift)
       | _ -> (Alinear exp, 0)
       end
-  | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)]) ->
+  | Cop(Cmuli, [arg; {exp=Cconst_int(2|4|8 as mult)}]) ->
       begin match select_addr arg with
         (Alinear e, n) -> (Ascale(e, mult), n * mult)
       | _ -> (Alinear exp, 0)
       end
-  | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg]) ->
+  | Cop(Cmuli, [{exp=Cconst_int(2|4|8 as mult)}; arg]) ->
       begin match select_addr arg with
         (Alinear e, n) -> (Ascale(e, mult), n * mult)
       | _ -> (Alinear exp, 0)
@@ -70,8 +71,8 @@ let rec select_addr exp =
         | _ ->
               (Aadd(arg1, arg2), 0)
       end
-  | arg ->
-      (Alinear arg, 0)
+  | _ ->
+      (Alinear exp, 0)
 
 (* Special constraints on operand and result registers *)
 
@@ -122,34 +123,36 @@ method is_immediate n = n <= 0x7FFFFFFF && n >= -0x80000000
 method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n
 
 method select_addressing exp =
+  let mk = mkdbg exp.Debuginfo.dbg in
   let (a, d) = select_addr exp in
   (* PR#4625: displacement must be a signed 32-bit immediate *)
   if d < -0x8000_0000 || d > 0x7FFF_FFFF
   then (Iindexed 0, exp)
   else match a with
     | Asymbol s ->
-        (Ibased(s, d), Ctuple [])
+        (Ibased(s, d), mk(Ctuple []))
     | Alinear e ->
         (Iindexed d, e)
     | Aadd(e1, e2) ->
-        (Iindexed2 d, Ctuple[e1; e2])
+        (Iindexed2 d, mk(Ctuple[e1; e2]))
     | Ascale(e, scale) ->
         (Iscaled(scale, d), e)
     | Ascaledadd(e1, e2, scale) ->
-        (Iindexed2scaled(scale, d), Ctuple[e1; e2])
+        (Iindexed2scaled(scale, d), mk(Ctuple[e1; e2]))
 
 method! select_store addr exp =
-  match exp with
+  let mk = mkdbg exp.Debuginfo.dbg in
+  match exp.exp with
     Cconst_int n when self#is_immediate n ->
-      (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple [])
+      (Ispecific(Istore_int(Nativeint.of_int n, addr)), mk(Ctuple []))
   | Cconst_natint n when self#is_immediate_natint n ->
-      (Ispecific(Istore_int(n, addr)), Ctuple [])
+      (Ispecific(Istore_int(n, addr)), mk(Ctuple []))
   | Cconst_pointer n when self#is_immediate n ->
-      (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple [])
+      (Ispecific(Istore_int(Nativeint.of_int n, addr)), mk(Ctuple []))
   | Cconst_natpointer n when self#is_immediate_natint n ->
-      (Ispecific(Istore_int(n, addr)), Ctuple [])
+      (Ispecific(Istore_int(n, addr)), mk(Ctuple []))
   | Cconst_symbol s when not (!pic_code || !Clflags.dlcode) ->
-      (Ispecific(Istore_symbol(s, addr)), Ctuple [])
+      (Ispecific(Istore_symbol(s, addr)), mk(Ctuple []))
   | _ ->
       super#select_store addr exp
 
@@ -157,7 +160,7 @@ method! select_operation op args =
   match op with
   (* Recognize the LEA instruction *)
     Caddi | Cadda | Csubi | Csuba ->
-      begin match self#select_addressing (Cop(op, args)) with
+      begin match self#select_addressing (mk(Cop(op, args))) with
         (Iindexed d, _) -> super#select_operation op args
       | (Iindexed2 0, _) -> super#select_operation op args
       | (addr, arg) -> (Ispecific(Ilea addr), [arg])
@@ -165,14 +168,14 @@ method! select_operation op args =
   (* Recognize (x / cst) and (x % cst) only if cst is a power of 2. *)
   | Cdivi ->
       begin match args with
-        [arg1; Cconst_int n] when self#is_immediate n
+        [arg1; {exp=Cconst_int n}] when self#is_immediate n
                                && n = 1 lsl (Misc.log2 n) ->
           (Iintop_imm(Idiv, n), [arg1])
       | _ -> (Iintop Idiv, args)
       end
   | Cmodi ->
       begin match args with
-        [arg1; Cconst_int n] when self#is_immediate n
+        [arg1; {exp=Cconst_int n}] when self#is_immediate n
                                && n = 1 lsl (Misc.log2 n) ->
           (Iintop_imm(Imod, n), [arg1])
       | _ -> (Iintop Imod, args)
@@ -189,7 +192,7 @@ method! select_operation op args =
   (* Recognize store instructions *)
   | Cstore Word ->
       begin match args with
-        [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])]
+        [loc; {exp=Cop(Caddi, [{exp=Cop(Cload _, [loc'])}; {exp=Cconst_int n}])}]
         when loc = loc' && self#is_immediate n ->
           let (addr, arg) = self#select_addressing loc in
           (Ispecific(Ioffset_loc(n, addr)), [arg])
@@ -202,11 +205,11 @@ method! select_operation op args =
 
 method select_floatarith commutative regular_op mem_op args =
   match args with
-    [arg1; Cop(Cload (Double|Double_u), [loc2])] ->
+    [arg1; {exp=Cop(Cload (Double|Double_u), [loc2])}] ->
       let (addr, arg2) = self#select_addressing loc2 in
       (Ispecific(Ifloatarithmem(mem_op, addr)),
                  [arg1; arg2])
-  | [Cop(Cload (Double|Double_u), [loc1]); arg2] when commutative ->
+  | [{exp=Cop(Cload (Double|Double_u), [loc1])}; arg2] when commutative ->
       let (addr, arg1) = self#select_addressing loc1 in
       (Ispecific(Ifloatarithmem(mem_op, addr)),
                  [arg2; arg1])
@@ -217,18 +220,15 @@ method select_floatarith commutative regular_op mem_op args =
 
 (* Deal with register constraints *)
 
-method! insert_op_debug op dbg rs rd =
+method! insert_op op dbg rs rd =
   try
     let (rsrc, rdst) = pseudoregs_for_operation op rs rd in
-    self#insert_moves rs rsrc;
-    self#insert_debug (Iop op) dbg rsrc rdst;
-    self#insert_moves rdst rd;
+    self#insert_moves dbg rs rsrc;
+    self#insert (Iop op) dbg rsrc rdst;
+    self#insert_moves dbg rdst rd;
     rd
   with Use_default ->
-    super#insert_op_debug op dbg rs rd
-
-method! insert_op op rs rd =
-  self#insert_op_debug op Debuginfo.none rs rd
+    super#insert_op op dbg rs rd
 
 end
 
diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml
index 4714696..a82fd60 100644
--- a/asmcomp/cmm.ml
+++ b/asmcomp/cmm.ml
@@ -67,8 +67,8 @@ type memory_chunk =
   | Double_u
 
 type operation =
-    Capply of machtype * Debuginfo.t
-  | Cextcall of string * machtype * bool * Debuginfo.t
+    Capply of machtype
+  | Cextcall of string * machtype * bool
   | Cload of memory_chunk
   | Calloc
   | Cstore of memory_chunk
@@ -81,10 +81,11 @@ type operation =
   | Caddf | Csubf | Cmulf | Cdivf
   | Cfloatofint | Cintoffloat
   | Ccmpf of comparison
-  | Craise of Debuginfo.t
-  | Ccheckbound of Debuginfo.t
+  | Craise
+  | Ccheckbound
 
-type expression =
+
+type expression_desc =
     Cconst_int of int
   | Cconst_natint of nativeint
   | Cconst_float of string
@@ -104,6 +105,8 @@ type expression =
   | Cexit of int * expression list
   | Ctrywith of expression * Ident.t * expression
 
+and expression = expression_desc Debuginfo.expression
+
 type fundecl =
   { fun_name: string;
     fun_args: (Ident.t * machtype) list;
diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli
index f579932..7aa8430 100644
--- a/asmcomp/cmm.mli
+++ b/asmcomp/cmm.mli
@@ -52,9 +52,10 @@ type memory_chunk =
   | Double                              (* 64-bit-aligned 64-bit float *)
   | Double_u                            (* word-aligned 64-bit float *)
 
+
 type operation =
-    Capply of machtype * Debuginfo.t
-  | Cextcall of string * machtype * bool * Debuginfo.t
+    Capply of machtype
+  | Cextcall of string * machtype * bool
   | Cload of memory_chunk
   | Calloc
   | Cstore of memory_chunk
@@ -67,10 +68,11 @@ type operation =
   | Caddf | Csubf | Cmulf | Cdivf
   | Cfloatofint | Cintoffloat
   | Ccmpf of comparison
-  | Craise of Debuginfo.t
-  | Ccheckbound of Debuginfo.t
+  | Craise
+  | Ccheckbound
+
 
-type expression =
+type expression_desc =
     Cconst_int of int
   | Cconst_natint of nativeint
   | Cconst_float of string
@@ -90,6 +92,8 @@ type expression =
   | Cexit of int * expression list
   | Ctrywith of expression * Ident.t * expression
 
+and expression = expression_desc Debuginfo.expression
+
 type fundecl =
   { fun_name: string;
     fun_args: (Ident.t * machtype) list;
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 2ee2ec6..78e28c0 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -29,16 +29,22 @@ open Cmx_format
 (* Local binding of complex expressions *)
 
 let bind name arg fn =
-  match arg with
+  match arg.exp with
     Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _
   | Cconst_pointer _ | Cconst_natpointer _ -> fn arg
-  | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))
+  | _ ->
+      let id = Ident.create name in
+      let mk = mkdbg arg.dbg in
+      mk(Clet(id, arg, fn (mk(Cvar id))))
 
 let bind_nonvar name arg fn =
-  match arg with
+  match arg.exp with
     Cconst_int _ | Cconst_natint _ | Cconst_symbol _
   | Cconst_pointer _ | Cconst_natpointer _ -> fn arg
-  | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))
+  | _ ->
+      let id = Ident.create name in
+      let mk = mkdbg arg.dbg in
+      mk(Clet(id, arg, fn (mk(Cvar id))))
 
 (* Block headers. Meaning of the tag field: see stdlib/obj.ml *)
 
@@ -80,188 +86,231 @@ let int_const n =
           (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n)
 
 let add_const c n =
-  if n = 0 then c else Cop(Caddi, [c; Cconst_int n])
-
-let incr_int = function
-    Cconst_int n when n < max_int -> Cconst_int(n+1)
-  | Cop(Caddi, [c; Cconst_int n]) when n < max_int -> add_const c (n + 1)
-  | c -> add_const c 1
-
-let decr_int = function
-    Cconst_int n when n > min_int -> Cconst_int(n-1)
-  | Cop(Caddi, [c; Cconst_int n]) when n > min_int -> add_const c (n - 1)
-  | c -> add_const c (-1)
+  if n = 0 then
+    c
+  else
+    let mk = mkdbg c.dbg in
+    mk(Cop(Caddi, [c; mk(Cconst_int n)]))
+
+let incr_int c =
+  let mk = mkdbg c.dbg in
+  match c.exp with
+    Cconst_int n when n < max_int -> mk(Cconst_int(n+1))
+  | Cop(Caddi, [c; {exp=Cconst_int n}]) when n < max_int -> add_const c (n + 1)
+  | _ -> add_const c 1
+
+let decr_int c =
+  let mk = mkdbg c.dbg in
+  match c.exp with
+    Cconst_int n when n > min_int -> mk(Cconst_int(n-1))
+  | Cop(Caddi, [c; {exp=Cconst_int n}]) when n > min_int -> add_const c (n - 1)
+  | _ -> add_const c (-1)
 
 let add_int c1 c2 =
-  match (c1, c2) with
-    (Cop(Caddi, [c1; Cconst_int n1]),
-     Cop(Caddi, [c2; Cconst_int n2])) when no_overflow_add n1 n2 ->
-      add_const (Cop(Caddi, [c1; c2])) (n1 + n2)
-  | (Cop(Caddi, [c1; Cconst_int n1]), c2) ->
-      add_const (Cop(Caddi, [c1; c2])) n1
-  | (c1, Cop(Caddi, [c2; Cconst_int n2])) ->
-      add_const (Cop(Caddi, [c1; c2])) n2
+  let mk = mkdbg c1.dbg in
+  match (c1.exp, c2.exp) with
+    (Cop(Caddi, [c1; {exp=Cconst_int n1}]),
+     Cop(Caddi, [c2; {exp=Cconst_int n2}])) when no_overflow_add n1 n2 ->
+      add_const (mk(Cop(Caddi, [c1; c2]))) (n1 + n2)
+  | (Cop(Caddi, [c1; {exp=Cconst_int n1}]), _) ->
+      add_const (mk(Cop(Caddi, [c1; c2]))) n1
+  | (_, Cop(Caddi, [c2; {exp=Cconst_int n2}])) ->
+      add_const (mk(Cop(Caddi, [c1; c2]))) n2
   | (Cconst_int _, _) ->
-      Cop(Caddi, [c2; c1])
+      mk(Cop(Caddi, [c2; c1]))
   | (_, _) ->
-      Cop(Caddi, [c1; c2])
+      mk(Cop(Caddi, [c1; c2]))
 
 let sub_int c1 c2 =
-  match (c1, c2) with
-    (Cop(Caddi, [c1; Cconst_int n1]),
-     Cop(Caddi, [c2; Cconst_int n2])) when no_overflow_sub n1 n2 ->
-      add_const (Cop(Csubi, [c1; c2])) (n1 - n2)
-  | (Cop(Caddi, [c1; Cconst_int n1]), c2) ->
-      add_const (Cop(Csubi, [c1; c2])) n1
-  | (c1, Cop(Caddi, [c2; Cconst_int n2])) when n2 <> min_int ->
-      add_const (Cop(Csubi, [c1; c2])) (-n2)
-  | (c1, Cconst_int n) when n <> min_int ->
+  let mk = mkdbg c1.dbg in
+  match (c1.exp, c2.exp) with
+    (Cop(Caddi, [c1; {exp=Cconst_int n1}]),
+     Cop(Caddi, [c2; {exp=Cconst_int n2}])) when no_overflow_sub n1 n2 ->
+      add_const (mk((Cop(Csubi, [c1; c2])))) (n1 - n2)
+  | (Cop(Caddi, [c1; {exp=Cconst_int n1}]), _) ->
+      add_const (mk(Cop(Csubi, [c1; c2]))) n1
+  | (_, Cop(Caddi, [c2; {exp=Cconst_int n2}])) when n2 <> min_int ->
+      add_const (mk(Cop(Csubi, [c1; c2]))) (-n2)
+  | (_, Cconst_int n) when n <> min_int ->
       add_const c1 (-n)
-  | (c1, c2) ->
-      Cop(Csubi, [c1; c2])
+  | (_, _) ->
+      mk(Cop(Csubi, [c1; c2]))
 
 let mul_int c1 c2 =
-  match (c1, c2) with
+  match (c1.exp, c2.exp) with
     (Cconst_int 0, _) -> c1
   | (Cconst_int 1, _) -> c2
   | (_, Cconst_int 0) -> c2
   | (_, Cconst_int 1) -> c1
-  | (_, _) -> Cop(Cmuli, [c1; c2])
-
-let tag_int = function
-    Cconst_int n -> int_const n
-  | c -> Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1])
-
-let force_tag_int = function
-    Cconst_int n -> int_const n
-  | c -> Cop(Cor, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1])
-
-let untag_int = function
-    Cconst_int n -> Cconst_int(n asr 1)
-  | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c
-  | Cop(Cor, [Cop(Casr, [c; Cconst_int n]); Cconst_int 1])
+  | (_, _) ->
+      let mk = mkdbg c1.dbg in
+      mk(Cop(Cmuli, [c1; c2]))
+
+let tag_int c =
+  let mk = mkdbg c.dbg in
+  match c.exp with
+    Cconst_int n -> mk(int_const n)
+  | _ -> mk(Cop(Caddi, [mk(Cop(Clsl, [c; mk(Cconst_int 1)])); mk(Cconst_int 1)]))
+
+let force_tag_int c =
+  let mk = mkdbg c.dbg in
+  match c.exp with
+    Cconst_int n -> mk(int_const n)
+  | _ -> mk(Cop(Cor, [mk(Cop(Clsl, [c; mk(Cconst_int 1)])); mk(Cconst_int 1)]))
+
+let untag_int c =
+  let mk = mkdbg c.dbg in
+  match c.exp with
+    Cconst_int n -> mk(Cconst_int(n asr 1))
+  | Cop(Caddi, [{exp=Cop(Clsl, [c; {exp=Cconst_int 1}])}; {exp=Cconst_int 1}]) -> c
+  | Cop(Cor, [{exp=Cop(Casr, [c; {exp=Cconst_int n}])}; {exp=Cconst_int 1}])
     when n > 0 && n < size_int * 8 ->
-      Cop(Casr, [c; Cconst_int (n+1)])
-  | Cop(Cor, [Cop(Clsr, [c; Cconst_int n]); Cconst_int 1])
+      mk(Cop(Casr, [c; mk(Cconst_int (n+1))]))
+  | Cop(Cor, [{exp=Cop(Clsr, [c; {exp=Cconst_int n}])}; {exp=Cconst_int 1}])
     when n > 0 && n < size_int * 8 ->
-      Cop(Clsr, [c; Cconst_int (n+1)])
-  | Cop(Cor, [c; Cconst_int 1]) -> Cop(Casr, [c; Cconst_int 1])
-  | c -> Cop(Casr, [c; Cconst_int 1])
+      mk(Cop(Clsr, [c; mk(Cconst_int (n+1))]))
+  | Cop(Cor, [c; {exp=Cconst_int 1}]) -> mk(Cop(Casr, [c; mk(Cconst_int 1)]))
+  | _ -> mk(Cop(Casr, [c; mk(Cconst_int 1)]))
 
 let lsl_int c1 c2 =
-  match (c1, c2) with
-    (Cop(Clsl, [c; Cconst_int n1]), Cconst_int n2)
+  let mk = mkdbg c1.dbg in
+  match (c1.exp, c2.exp) with
+    (Cop(Clsl, [c; {exp=Cconst_int n1}]), Cconst_int n2)
     when n1 > 0 && n2 > 0 && n1 + n2 < size_int * 8 ->
-      Cop(Clsl, [c; Cconst_int (n1 + n2)])
+      mk(Cop(Clsl, [c; mk(Cconst_int (n1 + n2))]))
   | (_, _) ->
-      Cop(Clsl, [c1; c2])
+      mk(Cop(Clsl, [c1; c2]))
 
-let ignore_low_bit_int = function
-    Cop(Caddi, [(Cop(Clsl, [_; Cconst_int 1]) as c); Cconst_int 1]) -> c
-  | Cop(Cor, [c; Cconst_int 1]) -> c
-  | c -> c
+let ignore_low_bit_int c = match c.exp with
+    Cop(Caddi, [({exp=Cop(Clsl, [_; {exp=Cconst_int 1}])} as c); {exp=Cconst_int 1}]) -> c
+  | Cop(Cor, [c; {exp=Cconst_int 1}]) -> c
+  | _ -> c
 
-let is_nonzero_constant = function
+let is_nonzero_constant c = match c.exp with
     Cconst_int n -> n <> 0
   | Cconst_natint n -> n <> 0n
   | _ -> false
 
 let safe_divmod op c1 c2 dbg =
+  let mk = mkdbg dbg in
   if !Clflags.fast || is_nonzero_constant c2 then
-    Cop(op, [c1; c2])
+    mk(Cop(op, [c1; c2]))
   else
     bind "divisor" c2 (fun c2 ->
-      Cifthenelse(c2,
-                  Cop(op, [c1; c2]),
-                  Cop(Craise dbg,
-                      [Cconst_symbol "caml_bucket_Division_by_zero"])))
+      mk(Cifthenelse(c2,
+                  mk(Cop(op, [c1; c2])),
+                  mk(Cop(Craise,
+                      [mk(Cconst_symbol "caml_bucket_Division_by_zero")])))))
 
 (* Bool *)
 
-let test_bool = function
-    Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c
-  | Cop(Clsl, [c; Cconst_int 1]) -> c
-  | c -> Cop(Ccmpi Cne, [c; Cconst_int 1])
+let test_bool c = match c.exp with
+    Cop(Caddi, [{exp=Cop(Clsl, [c; {exp=Cconst_int 1}])}; {exp=Cconst_int 1}]) -> c
+  | Cop(Clsl, [c; {exp=Cconst_int 1}]) -> c
+  | _ ->
+    let mk = mkdbg c.dbg in
+    mk(Cop(Ccmpi Cne, [c; mk(Cconst_int 1)]))
 
 (* Float *)
 
-let box_float c = Cop(Calloc, [alloc_float_header; c])
+let box_float c =
+  let mk = mkdbg c.dbg in
+  mk(Cop(Calloc, [mk alloc_float_header; c]))
 
-let rec unbox_float = function
+let rec unbox_float c =
+  let mk = mkdbg c.dbg in
+  match c.exp with
     Cop(Calloc, [header; c]) -> c
-  | Clet(id, exp, body) -> Clet(id, exp, unbox_float body)
+  | Clet(id, exp, body) -> mk(Clet(id, exp, unbox_float body))
   | Cifthenelse(cond, e1, e2) ->
-      Cifthenelse(cond, unbox_float e1, unbox_float e2)
-  | Csequence(e1, e2) -> Csequence(e1, unbox_float e2)
-  | Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map unbox_float el)
-  | Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_float e1, unbox_float e2)
-  | Ctrywith(e1, id, e2) -> Ctrywith(unbox_float e1, id, unbox_float e2)
-  | c -> Cop(Cload Double_u, [c])
+      mk(Cifthenelse(cond, unbox_float e1, unbox_float e2))
+  | Csequence(e1, e2) -> mk(Csequence(e1, unbox_float e2))
+  | Cswitch(e, tbl, el) -> mk(Cswitch(e, tbl, Array.map unbox_float el))
+  | Ccatch(n, ids, e1, e2) -> mk(Ccatch(n, ids, unbox_float e1, unbox_float e2))
+  | Ctrywith(e1, id, e2) -> mk(Ctrywith(unbox_float e1, id, unbox_float e2))
+  | _ -> mk(Cop(Cload Double_u, [c]))
 
 (* Complex *)
 
 let box_complex c_re c_im =
-  Cop(Calloc, [alloc_floatarray_header 2; c_re; c_im])
+  let mk = mkdbg c_re.dbg in
+  mk(Cop(Calloc, [mk(alloc_floatarray_header 2); c_re; c_im]))
 
-let complex_re c = Cop(Cload Double_u, [c])
-let complex_im c = Cop(Cload Double_u,
-                       [Cop(Cadda, [c; Cconst_int size_float])])
+let complex_re c =
+  let mk = mkdbg c.dbg in
+  mk(Cop(Cload Double_u, [c]))
+
+let complex_im c =
+  let mk = mkdbg c.dbg in
+  mk(Cop(Cload Double_u,
+          [mk(Cop(Cadda, [c; mk(Cconst_int size_float)]))]))
 
 (* Unit *)
 
-let return_unit c = Csequence(c, Cconst_pointer 1)
+let return_unit c =
+  let mk = mkdbg c.dbg in
+  mk(Csequence(c, mk(Cconst_pointer 1)))
 
-let rec remove_unit = function
-    Cconst_pointer 1 -> Ctuple []
-  | Csequence(c, Cconst_pointer 1) -> c
+let rec remove_unit c =
+  let mk = mkdbg c.dbg in
+  match c.exp with
+    Cconst_pointer 1 -> mk(Ctuple [])
+  | Csequence(c, {exp=Cconst_pointer 1}) -> c
   | Csequence(c1, c2) ->
-      Csequence(c1, remove_unit c2)
+      mk(Csequence(c1, remove_unit c2))
   | Cifthenelse(cond, ifso, ifnot) ->
-      Cifthenelse(cond, remove_unit ifso, remove_unit ifnot)
+      mk(Cifthenelse(cond, remove_unit ifso, remove_unit ifnot))
   | Cswitch(sel, index, cases) ->
-      Cswitch(sel, index, Array.map remove_unit cases)
+      mk(Cswitch(sel, index, Array.map remove_unit cases))
   | Ccatch(io, ids, body, handler) ->
-      Ccatch(io, ids, remove_unit body, remove_unit handler)
+      mk(Ccatch(io, ids, remove_unit body, remove_unit handler))
   | Ctrywith(body, exn, handler) ->
-      Ctrywith(remove_unit body, exn, remove_unit handler)
+      mk(Ctrywith(remove_unit body, exn, remove_unit handler))
   | Clet(id, c1, c2) ->
-      Clet(id, c1, remove_unit c2)
-  | Cop(Capply (mty, dbg), args) ->
-      Cop(Capply (typ_void, dbg), args)
-  | Cop(Cextcall(proc, mty, alloc, dbg), args) ->
-      Cop(Cextcall(proc, typ_void, alloc, dbg), args)
-  | Cexit (_,_) as c -> c
-  | Ctuple [] as c -> c
-  | c -> Csequence(c, Ctuple [])
+      mk(Clet(id, c1, remove_unit c2))
+  | Cop(Capply mty, args) ->
+      mk(Cop(Capply (typ_void), args))
+  | Cop(Cextcall(proc, mty, alloc), args) ->
+      mk(Cop(Cextcall(proc, typ_void, alloc), args))
+  | Cexit (_,_) -> c
+  | Ctuple [] -> c
+  | _ -> mk(Csequence(c, mk(Ctuple [])))
 
 (* Access to block fields *)
 
 let field_address ptr n =
   if n = 0
   then ptr
-  else Cop(Cadda, [ptr; Cconst_int(n * size_addr)])
+  else
+    let mk = mkdbg ptr.dbg in
+    mk(Cop(Cadda, [ptr; mk(Cconst_int(n * size_addr))]))
 
 let get_field ptr n =
-  Cop(Cload Word, [field_address ptr n])
+  let mk = mkdbg ptr.dbg in
+  mk(Cop(Cload Word, [field_address ptr n]))
 
 let set_field ptr n newval =
-  Cop(Cstore Word, [field_address ptr n; newval])
+  let mk = mkdbg ptr.dbg in
+  mk(Cop(Cstore Word, [field_address ptr n; newval]))
 
 let header ptr =
-  Cop(Cload Word, [Cop(Cadda, [ptr; Cconst_int(-size_int)])])
+  let mk = mkdbg ptr.dbg in
+  mk(Cop(Cload Word, [mk(Cop(Cadda, [ptr; mk(Cconst_int(-size_int))]))]))
 
 let tag_offset =
   if big_endian then -1 else -size_int
 
 let get_tag ptr =
+  let mk = mkdbg ptr.dbg in
   if Proc.word_addressed then           (* If byte loads are slow *)
-    Cop(Cand, [header ptr; Cconst_int 255])
+    mk(Cop(Cand, [header ptr; mk(Cconst_int 255)]))
   else                                  (* If byte loads are efficient *)
-    Cop(Cload Byte_unsigned,
-        [Cop(Cadda, [ptr; Cconst_int(tag_offset)])])
+    mk(Cop(Cload Byte_unsigned,
+        [mk(Cop(Cadda, [ptr; mk(Cconst_int(tag_offset))]))]))
 
 let get_size ptr =
-  Cop(Clsr, [header ptr; Cconst_int 10])
+  let mk = mkdbg ptr.dbg in
+  mk(Cop(Clsr, [header ptr; mk(Cconst_int 10)]))
 
 (* Array indexing *)
 
@@ -272,108 +321,126 @@ let wordsize_shift = 9
 let numfloat_shift = 9 + log2_size_float - log2_size_addr
 
 let is_addr_array_hdr hdr =
-  Cop(Ccmpi Cne, [Cop(Cand, [hdr; Cconst_int 255]); floatarray_tag])
+  let mk = mkdbg hdr.dbg in
+  mk(Cop(Ccmpi Cne, [mk(Cop(Cand, [hdr; mk(Cconst_int 255)])); mk floatarray_tag]))
 
 let is_addr_array_ptr ptr =
-  Cop(Ccmpi Cne, [get_tag ptr; floatarray_tag])
+  let mk = mkdbg ptr.dbg in
+  mk(Cop(Ccmpi Cne, [get_tag ptr; mk floatarray_tag]))
 
-let addr_array_length hdr = Cop(Clsr, [hdr; Cconst_int wordsize_shift])
-let float_array_length hdr = Cop(Clsr, [hdr; Cconst_int numfloat_shift])
+let addr_array_length hdr =
+  let mk = mkdbg hdr.dbg in
+  mk(Cop(Clsr, [hdr; mk(Cconst_int wordsize_shift)]))
+
+let float_array_length hdr =
+  let mk = mkdbg hdr.dbg in
+  mk(Cop(Clsr, [hdr; mk(Cconst_int numfloat_shift)]))
 
 let lsl_const c n =
-  Cop(Clsl, [c; Cconst_int n])
+  let mk = mkdbg c.dbg in
+  mk(Cop(Clsl, [c; mk(Cconst_int n)]))
 
 let array_indexing log2size ptr ofs =
-  match ofs with
+  let mk = mkdbg ptr.dbg in
+  match ofs.exp with
     Cconst_int n ->
       let i = n asr 1 in
-      if i = 0 then ptr else Cop(Cadda, [ptr; Cconst_int(i lsl log2size)])
-  | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) ->
-      Cop(Cadda, [ptr; lsl_const c log2size])
-  | Cop(Caddi, [c; Cconst_int n]) ->
-      Cop(Cadda, [Cop(Cadda, [ptr; lsl_const c (log2size - 1)]);
-                   Cconst_int((n-1) lsl (log2size - 1))])
+      if i = 0 then ptr else mk(Cop(Cadda, [ptr; mk(Cconst_int(i lsl log2size))]))
+  | Cop(Caddi, [{exp=Cop(Clsl, [c; {exp=Cconst_int 1}])}; {exp=Cconst_int 1}]) ->
+      mk(Cop(Cadda, [ptr; lsl_const c log2size]))
+  | Cop(Caddi, [c; {exp=Cconst_int n}]) ->
+      mk(Cop(Cadda, [mk(Cop(Cadda, [ptr; lsl_const c (log2size - 1)]));
+                      mk(Cconst_int((n-1) lsl (log2size - 1)))]))
   | _ ->
-      Cop(Cadda, [Cop(Cadda, [ptr; lsl_const ofs (log2size - 1)]);
-                   Cconst_int((-1) lsl (log2size - 1))])
+      mk(Cop(Cadda, [mk(Cop(Cadda, [ptr; lsl_const ofs (log2size - 1)]));
+                      mk(Cconst_int((-1) lsl (log2size - 1)))]))
 
 let addr_array_ref arr ofs =
-  Cop(Cload Word, [array_indexing log2_size_addr arr ofs])
+  let mk = mkdbg arr.dbg in
+  mk(Cop(Cload Word, [array_indexing log2_size_addr arr ofs]))
 
 let unboxed_float_array_ref arr ofs =
-  Cop(Cload Double_u, [array_indexing log2_size_float arr ofs])
+  let mk = mkdbg arr.dbg in
+  mk(Cop(Cload Double_u, [array_indexing log2_size_float arr ofs]))
 
 let float_array_ref arr ofs =
   box_float(unboxed_float_array_ref arr ofs)
 
 let addr_array_set arr ofs newval =
-  Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none),
-      [array_indexing log2_size_addr arr ofs; newval])
+  let mk = mkdbg arr.dbg in
+  mk(Cop(Cextcall("caml_modify", typ_void, false),
+          [array_indexing log2_size_addr arr ofs; newval]))
 
 let int_array_set arr ofs newval =
-  Cop(Cstore Word, [array_indexing log2_size_addr arr ofs; newval])
+  let mk = mkdbg arr.dbg in
+  mk(Cop(Cstore Word, [array_indexing log2_size_addr arr ofs; newval]))
 
 let float_array_set arr ofs newval =
-  Cop(Cstore Double_u, [array_indexing log2_size_float arr ofs; newval])
+  let mk = mkdbg arr.dbg in
+  mk(Cop(Cstore Double_u, [array_indexing log2_size_float arr ofs; newval]))
 
 (* String length *)
 
 let string_length exp =
   bind "str" exp (fun str ->
     let tmp_var = Ident.create "tmp" in
-    Clet(tmp_var,
-         Cop(Csubi,
-             [Cop(Clsl,
-                   [Cop(Clsr, [header str; Cconst_int 10]);
-                     Cconst_int log2_size_addr]);
-              Cconst_int 1]),
-         Cop(Csubi,
-             [Cvar tmp_var;
-               Cop(Cload Byte_unsigned,
-                     [Cop(Cadda, [str; Cvar tmp_var])])])))
+    let mk = mkdbg exp.dbg in
+    mk(Clet(tmp_var,
+             mk(Cop(Csubi,
+                     [mk(Cop(Clsl,
+                              [mk(Cop(Clsr, [header str; mk(Cconst_int 10)]));
+                               mk(Cconst_int log2_size_addr)]));
+                      mk(Cconst_int 1)])),
+             mk(Cop(Csubi,
+                     [mk(Cvar tmp_var);
+                      mk(Cop(Cload Byte_unsigned,
+                              [mk(Cop(Cadda, [str; mk(Cvar tmp_var)]))]))])))))
 
 (* Message sending *)
 
 let lookup_tag obj tag =
   bind "tag" tag (fun tag ->
-    Cop(Cextcall("caml_get_public_method", typ_addr, false, Debuginfo.none),
-        [obj; tag]))
+    let mk = mkdbg obj.dbg in
+    mk(Cop(Cextcall("caml_get_public_method", typ_addr, false), [obj; tag])))
 
 let lookup_label obj lab =
   bind "lab" lab (fun lab ->
-    let table = Cop (Cload Word, [obj]) in
+    let mk = mkdbg obj.dbg in
+    let table = mk(Cop (Cload Word, [obj])) in
     addr_array_ref table lab)
 
 let call_cached_method obj tag cache pos args dbg =
   let arity = List.length args in
   let cache = array_indexing log2_size_addr cache pos in
+  let mk = mkdbg obj.dbg in
   Compilenv.need_send_fun arity;
-  Cop(Capply (typ_addr, dbg),
-      Cconst_symbol("caml_send" ^ string_of_int arity) ::
-      obj :: tag :: cache :: args)
+  mk(Cop(Capply (typ_addr),
+          mk(Cconst_symbol("caml_send" ^ string_of_int arity)) ::
+            obj :: tag :: cache :: args))
 
 (* Allocation *)
 
-let make_alloc_generic set_fn tag wordsize args =
+let make_alloc_generic set_fn tag wordsize args dbg =
+  let mk = mkdbg dbg in
   if wordsize <= Config.max_young_wosize then
-    Cop(Calloc, Cconst_natint(block_header tag wordsize) :: args)
+    mk(Cop(Calloc, mk(Cconst_natint(block_header tag wordsize)) :: args))
   else begin
     let id = Ident.create "alloc" in
     let rec fill_fields idx = function
-      [] -> Cvar id
-    | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1,
-                          fill_fields (idx + 2) el) in
-    Clet(id,
-         Cop(Cextcall("caml_alloc", typ_addr, true, Debuginfo.none),
-                 [Cconst_int wordsize; Cconst_int tag]),
-         fill_fields 1 args)
+      | []     -> mk(Cvar id)
+      | e1::el -> mk(Csequence(set_fn (mk(Cvar id)) (mk(Cconst_int idx)) e1,
+                                fill_fields (idx + 2) el)) in
+    mk(Clet(id,
+             mk(Cop(Cextcall("caml_alloc", typ_addr, true),
+                    [mk(Cconst_int wordsize); mk(Cconst_int tag)])),
+             fill_fields 1 args))
   end
 
-let make_alloc tag args =
-  make_alloc_generic addr_array_set tag (List.length args) args
-let make_float_alloc tag args =
+let make_alloc tag args dbg =
+  make_alloc_generic addr_array_set tag (List.length args) args dbg
+let make_float_alloc tag args dbg =
   make_alloc_generic float_array_set tag
-                     (List.length args * size_float / size_addr) args
+                     (List.length args * size_float / size_addr) args dbg
 
 (* To compile "let rec" over values *)
 
@@ -438,20 +505,22 @@ let new_const_symbol () =
 
 let structured_constants = ref ([] : (string * structured_constant) list)
 
-let transl_constant = function
+let transl_constant dbg c =
+  let mk = mkdbg dbg in
+  match c with
     Const_base(Const_int n) ->
-      int_const n
+      mk(int_const n)
   | Const_base(Const_char c) ->
-      Cconst_int(((Char.code c) lsl 1) + 1)
+      mk(Cconst_int (((Char.code c) lsl 1) + 1))
   | Const_pointer n ->
       if n <= max_repr_int && n >= min_repr_int
-      then Cconst_pointer((n lsl 1) + 1)
-      else Cconst_natpointer
-              (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n)
+      then mk(Cconst_pointer((n lsl 1) + 1))
+      else mk(Cconst_natpointer
+                        (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n))
   | cst ->
       let lbl = new_const_symbol() in
       structured_constants := (lbl, cst) :: !structured_constants;
-      Cconst_symbol lbl
+      mk(Cconst_symbol lbl)
 
 (* Translate constant closures *)
 
@@ -479,46 +548,50 @@ let alloc_header_boxed_int bi =
   | Pint64 -> alloc_boxedint64_header
 
 let box_int bi arg =
-  match arg with
+  let dbg = arg.dbg in
+  let mk = mkdbg dbg in
+  match arg.exp with
     Cconst_int n ->
-      transl_constant (box_int_constant bi (Nativeint.of_int n))
+      transl_constant dbg (box_int_constant bi (Nativeint.of_int n))
   | Cconst_natint n ->
-      transl_constant (box_int_constant bi n)
+      transl_constant dbg (box_int_constant bi n)
   | _ ->
       let arg' =
         if bi = Pint32 && size_int = 8 && big_endian
-        then Cop(Clsl, [arg; Cconst_int 32])
+        then mk(Cop(Clsl, [arg; mk(Cconst_int 32)]))
         else arg in
-      Cop(Calloc, [alloc_header_boxed_int bi;
-                   Cconst_symbol(operations_boxed_int bi);
-                   arg'])
+      mk(Cop(Calloc, [mk(alloc_header_boxed_int bi);
+                       mk(Cconst_symbol(operations_boxed_int bi));
+                       arg']))
 
 let rec unbox_int bi arg =
-  match arg with
-    Cop(Calloc, [hdr; ops; Cop(Clsl, [contents; Cconst_int 32])])
+  let mk = mkdbg arg.dbg in
+  match arg.exp with
+    Cop(Calloc, [hdr; ops; {exp=Cop(Clsl, [contents; {exp=Cconst_int 32}])}])
     when bi = Pint32 && size_int = 8 && big_endian ->
       (* Force sign-extension of low 32 bits *)
-      Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32])
+      mk(Cop(Casr, [mk(Cop(Clsl, [contents; mk(Cconst_int 32)])); mk(Cconst_int 32)]))
   | Cop(Calloc, [hdr; ops; contents])
     when bi = Pint32 && size_int = 8 && not big_endian ->
       (* Force sign-extension of low 32 bits *)
-      Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32])
+      mk(Cop(Casr, [mk(Cop(Clsl, [contents; mk(Cconst_int 32)])); mk(Cconst_int 32)]))
   | Cop(Calloc, [hdr; ops; contents]) ->
       contents
-  | Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body)
+  | Clet(id, exp, body) -> mk(Clet(id, exp, unbox_int bi body))
   | Cifthenelse(cond, e1, e2) ->
-      Cifthenelse(cond, unbox_int bi e1, unbox_int bi e2)
-  | Csequence(e1, e2) -> Csequence(e1, unbox_int bi e2)
-  | Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map (unbox_int bi) el)
-  | Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_int bi e1, unbox_int bi e2)
-  | Ctrywith(e1, id, e2) -> Ctrywith(unbox_int bi e1, id, unbox_int bi e2)
+      mk(Cifthenelse(cond, unbox_int bi e1, unbox_int bi e2))
+  | Csequence(e1, e2) -> mk(Csequence(e1, unbox_int bi e2))
+  | Cswitch(e, tbl, el) -> mk(Cswitch(e, tbl, Array.map (unbox_int bi) el))
+  | Ccatch(n, ids, e1, e2) -> mk(Ccatch(n, ids, unbox_int bi e1, unbox_int bi e2))
+  | Ctrywith(e1, id, e2) -> mk(Ctrywith(unbox_int bi e1, id, unbox_int bi e2))
   | _ ->
-      Cop(Cload(if bi = Pint32 then Thirtytwo_signed else Word),
-          [Cop(Cadda, [arg; Cconst_int size_addr])])
+      mk(Cop(Cload(if bi = Pint32 then Thirtytwo_signed else Word),
+              [mk(Cop(Cadda, [arg; mk(Cconst_int size_addr)]))]))
 
 let make_unsigned_int bi arg =
+  let mk = mkdbg arg.dbg in
   if bi = Pint32 && size_int = 8
-  then Cop(Cand, [arg; Cconst_natint 0xFFFFFFFFn])
+  then mk(Cop(Cand, [arg; mk(Cconst_natint 0xFFFFFFFFn)]))
   else arg
 
 (* Big arrays *)
@@ -539,19 +612,21 @@ let bigarray_elt_size = function
   | Pbigarray_complex64 -> 16
 
 let bigarray_indexing unsafe elt_kind layout b args dbg =
+  let mk = mkdbg dbg in
   let check_bound a1 a2 k =
-    if unsafe then k else Csequence(Cop(Ccheckbound dbg, [a1;a2]), k) in
+    if unsafe then k else
+      mk(Csequence(mk(Cop(Ccheckbound, [a1;a2])), k)) in
   let rec ba_indexing dim_ofs delta_ofs = function
     [] -> assert false
   | [arg] ->
       bind "idx" (untag_int arg)
         (fun idx ->
-           check_bound (Cop(Cload Word,[field_address b dim_ofs])) idx idx)
+          check_bound (mk(Cop(Cload Word,[field_address b dim_ofs]))) idx idx)
   | arg1 :: argl ->
       let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in
       bind "idx" (untag_int arg1)
         (fun idx ->
-          bind "bound" (Cop(Cload Word, [field_address b dim_ofs]))
+          bind "bound" (mk(Cop(Cload Word, [field_address b dim_ofs])))
           (fun bound ->
             check_bound bound idx (add_int (mul_int rem bound) idx))) in
   let offset =
@@ -561,14 +636,14 @@ let bigarray_indexing unsafe elt_kind layout b args dbg =
     | Pbigarray_c_layout ->
         ba_indexing (4 + List.length args) (-1) (List.rev args)
     | Pbigarray_fortran_layout ->
-        ba_indexing 5 1 (List.map (fun idx -> sub_int idx (Cconst_int 2)) args)
+        ba_indexing 5 1 (List.map (fun idx -> sub_int idx (mk(Cconst_int 2))) args)
   and elt_size =
     bigarray_elt_size elt_kind in
   let byte_offset =
     if elt_size = 1
     then offset
-    else Cop(Clsl, [offset; Cconst_int(log2 elt_size)]) in
-  Cop(Cadda, [Cop(Cload Word, [field_address b 1]); byte_offset])
+    else mk(Cop(Clsl, [offset; mk(Cconst_int(log2 elt_size))])) in
+  mk(Cop(Cadda, [mk(Cop(Cload Word, [field_address b 1])); byte_offset]))
 
 let bigarray_word_kind = function
     Pbigarray_unknown -> assert false
@@ -586,6 +661,7 @@ let bigarray_word_kind = function
   | Pbigarray_complex64 -> Double
 
 let bigarray_get unsafe elt_kind layout b args dbg =
+  let mk = mkdbg dbg in
   bind "ba" b (fun b ->
     match elt_kind with
       Pbigarray_complex32 | Pbigarray_complex64 ->
@@ -593,13 +669,14 @@ let bigarray_get unsafe elt_kind layout b args dbg =
         let sz = bigarray_elt_size elt_kind / 2 in
         bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
           box_complex
-            (Cop(Cload kind, [addr]))
-            (Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])])))
+            (mk(Cop(Cload kind, [addr])))
+            (mk(Cop(Cload kind, [mk(Cop(Cadda, [addr; mk(Cconst_int sz)]))]))))
     | _ ->
-        Cop(Cload (bigarray_word_kind elt_kind),
-            [bigarray_indexing unsafe elt_kind layout b args dbg]))
+        mk(Cop(Cload (bigarray_word_kind elt_kind),
+                [bigarray_indexing unsafe elt_kind layout b args dbg])))
 
 let bigarray_set unsafe elt_kind layout b args newval dbg =
+  let mk = mkdbg dbg in
   bind "ba" b (fun b ->
     match elt_kind with
       Pbigarray_complex32 | Pbigarray_complex64 ->
@@ -607,13 +684,13 @@ let bigarray_set unsafe elt_kind layout b args newval dbg =
         let sz = bigarray_elt_size elt_kind / 2 in
         bind "newval" newval (fun newv ->
         bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
-          Csequence(
-            Cop(Cstore kind, [addr; complex_re newv]),
-            Cop(Cstore kind,
-                [Cop(Cadda, [addr; Cconst_int sz]); complex_im newv]))))
+          mk(Csequence(
+            mk(Cop(Cstore kind, [addr; complex_re newv])),
+            mk(Cop(Cstore kind,
+                [mk(Cop(Cadda, [addr; mk(Cconst_int sz)])); complex_im newv]))))))
     | _ ->
-        Cop(Cstore (bigarray_word_kind elt_kind),
-            [bigarray_indexing unsafe elt_kind layout b args dbg; newval]))
+        mk(Cop(Cstore (bigarray_word_kind elt_kind),
+            [bigarray_indexing unsafe elt_kind layout b args dbg; newval])))
 
 (* Simplification of some primitives into C calls *)
 
@@ -673,7 +750,9 @@ let simplif_primitive p =
 
 (* constants first *)
 
-let transl_isout h arg = tag_int (Cop(Ccmpa Clt, [h ; arg]))
+let transl_isout h arg =
+  let mk = mkdbg arg.dbg in
+  tag_int (mk(Cop(Ccmpa Clt, [h ; arg])))
 
 exception Found of int
 
@@ -688,11 +767,12 @@ let make_switch_gen arg cases acts =
     new_cases.(i) <- new_act
   done ;
 
-  Cswitch
+  let mk = mkdbg arg.dbg in
+  mk(Cswitch
     (arg, new_cases,
      Array.map
        (fun n -> acts.(n))
-       (store.Switch.act_get ()))
+       (store.Switch.act_get ())))
 
 
 (* Then for blocks *)
@@ -710,12 +790,12 @@ struct
 
   type act = expression
 
-  let default = Cexit (0,[])
-  let make_prim p args = Cop (p,args)
+  let default = mk(Cexit (0,[]))
+  let make_prim p args = mk(Cop (p,args))
   let make_offset arg n = add_const arg n
-  let make_isout h arg =  Cop (Ccmpa Clt, [h ; arg])
-  let make_isin h arg =  Cop (Ccmpa Cge, [h ; arg])
-  let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot)
+  let make_isout h arg =  mkdbg arg.dbg (Cop (Ccmpa Clt, [h ; arg]))
+  let make_isin h arg =  mkdbg arg.dbg (Cop (Ccmpa Cge, [h ; arg]))
+  let make_if cond ifso ifnot = mkdbg cond.dbg (Cifthenelse (cond, ifso, ifnot))
   let make_switch arg cases actions =
     make_switch_gen arg cases actions
   let bind arg body = bind "switcher" arg body
@@ -732,8 +812,7 @@ type unboxed_number_kind =
   | Boxed_float
   | Boxed_integer of boxed_integer
 
-let is_unboxed_number ulam =
-  match ulam.exp with
+let is_unboxed_number ulam = match ulam.exp with
     Uconst(Const_base(Const_float f)) ->
       Boxed_float
   | Uprim(p, _) ->
@@ -775,31 +854,33 @@ let is_unboxed_number ulam =
 let subst_boxed_number unbox_fn boxed_id unboxed_id exp =
   let need_boxed = ref false in
   let assigned = ref false in
-  let rec subst = function
-      Cvar id as e ->
-        if Ident.same id boxed_id then need_boxed := true; e
-    | Clet(id, arg, body) -> Clet(id, subst arg, subst body)
+  let rec subst c =
+    let mk = mkdbg c.dbg in
+    match c.exp with
+      Cvar id ->
+        if Ident.same id boxed_id then need_boxed := true; c
+    | Clet(id, arg, body) -> mk(Clet(id, subst arg, subst body))
     | Cassign(id, arg) ->
         if Ident.same id boxed_id then begin
           assigned := true;
-          Cassign(unboxed_id, subst(unbox_fn arg))
+          mk(Cassign(unboxed_id, subst(unbox_fn arg)))
         end else
-          Cassign(id, subst arg)
-    | Ctuple argv -> Ctuple(List.map subst argv)
-    | Cop(Cload _, [Cvar id]) as e ->
-        if Ident.same id boxed_id then Cvar unboxed_id else e
-    | Cop(Cload _, [Cop(Cadda, [Cvar id; _])]) as e ->
-        if Ident.same id boxed_id then Cvar unboxed_id else e
-    | Cop(op, argv) -> Cop(op, List.map subst argv)
-    | Csequence(e1, e2) -> Csequence(subst e1, subst e2)
-    | Cifthenelse(e1, e2, e3) -> Cifthenelse(subst e1, subst e2, subst e3)
+          mk(Cassign(id, subst arg))
+    | Ctuple argv -> mk(Ctuple(List.map subst argv))
+    | Cop(Cload _, [{exp=Cvar id}]) ->
+        if Ident.same id boxed_id then mk(Cvar unboxed_id) else c
+    | Cop(Cload _, [{exp=Cop(Cadda, [{exp=Cvar id}; _])}]) ->
+        if Ident.same id boxed_id then mk(Cvar unboxed_id) else c
+    | Cop(op, argv) -> mk(Cop(op, List.map subst argv))
+    | Csequence(e1, e2) -> mk(Csequence(subst e1, subst e2))
+    | Cifthenelse(e1, e2, e3) -> mk(Cifthenelse(subst e1, subst e2, subst e3))
     | Cswitch(arg, index, cases) ->
-        Cswitch(subst arg, index, Array.map subst cases)
-    | Cloop e -> Cloop(subst e)
-    | Ccatch(nfail, ids, e1, e2) -> Ccatch(nfail, ids, subst e1, subst e2)
-    | Cexit (nfail, el) -> Cexit (nfail, List.map subst el)
-    | Ctrywith(e1, id, e2) -> Ctrywith(subst e1, id, subst e2)
-    | e -> e in
+        mk(Cswitch(subst arg, index, Array.map subst cases))
+    | Cloop e -> mk(Cloop(subst e))
+    | Ccatch(nfail, ids, e1, e2) -> mk(Ccatch(nfail, ids, subst e1, subst e2))
+    | Cexit (nfail, el) -> mk(Cexit (nfail, List.map subst el))
+    | Ctrywith(e1, id, e2) -> mk(Ctrywith(subst e1, id, subst e2))
+    | _ -> c in
   let res = subst exp in
   (res, !need_boxed, !assigned)
 
@@ -812,14 +893,14 @@ let rec transl ulam =
   let mk = mkdbg dbg in
   match ulam.exp with
     Uvar id ->
-      Cvar id
+      mk(Cvar id)
   | Uconst sc ->
-      transl_constant sc
+      transl_constant dbg sc
   | Uclosure(fundecls, []) ->
       let lbl = new_const_symbol() in
       constant_closures := (lbl, fundecls) :: !constant_closures;
       List.iter (fun f -> Queue.add f functions) fundecls;
-      Cconst_symbol lbl
+      mk(Cconst_symbol lbl)
   | Uclosure(fundecls, clos_vars) ->
       let block_size =
         fundecls_size fundecls + List.length clos_vars in
@@ -828,43 +909,44 @@ let rec transl ulam =
             List.map transl clos_vars
         | f :: rem ->
             Queue.add f functions;
+            let mk = mkdbg f.Clambda.dbg in
             let header =
               if pos = 0
-              then alloc_closure_header block_size
-              else alloc_infix_header pos in
+              then mk(alloc_closure_header block_size)
+              else mk(alloc_infix_header pos) in
             if f.arity = 1 then
               header ::
-              Cconst_symbol f.label ::
-              int_const 1 ::
+              mk(Cconst_symbol f.label) ::
+              mk(int_const 1) ::
               transl_fundecls (pos + 3) rem
             else
               header ::
-              Cconst_symbol(curry_function f.arity) ::
-              int_const f.arity ::
-              Cconst_symbol f.label ::
+              mk(Cconst_symbol(curry_function f.arity)) ::
+              mk(int_const f.arity) ::
+              mk(Cconst_symbol f.label) ::
               transl_fundecls (pos + 4) rem in
-      Cop(Calloc, transl_fundecls 0 fundecls)
+      mk(Cop(Calloc, transl_fundecls 0 fundecls))
   | Uoffset(arg, offset) ->
       field_address (transl arg) offset
   | Udirect_apply(lbl, args) ->
-      Cop(Capply(typ_addr, dbg), Cconst_symbol lbl :: List.map transl args)
+      mk(Cop(Capply(typ_addr), mk(Cconst_symbol lbl) :: List.map transl args))
   | Ugeneric_apply(clos, [arg]) ->
       bind "fun" (transl clos) (fun clos ->
-        Cop(Capply(typ_addr, dbg), [get_field clos 0; transl arg; clos]))
+        mk(Cop(Capply(typ_addr), [get_field clos 0; transl arg; clos])))
   | Ugeneric_apply(clos, args) ->
       let arity = List.length args in
-      let cargs = Cconst_symbol(apply_function arity) ::
+      let cargs = mk(Cconst_symbol(apply_function arity)) ::
         List.map transl (args @ [clos]) in
-      Cop(Capply(typ_addr, dbg), cargs)
+      mk(Cop(Capply typ_addr, cargs))
   | Usend(kind, met, obj, args) ->
       let call_met obj args clos =
         if args = [] then
-          Cop(Capply(typ_addr, dbg), [get_field clos 0;obj;clos])
+          mk(Cop(Capply typ_addr, [get_field clos 0;obj;clos]))
         else
           let arity = List.length args + 1 in
-          let cargs = Cconst_symbol(apply_function arity) :: obj ::
+          let cargs = mk(Cconst_symbol(apply_function arity)) :: obj ::
             (List.map transl args) @ [clos] in
-          Cop(Capply(typ_addr, dbg), cargs)
+          mk(Cop(Capply typ_addr, cargs))
       in
       bind "obj" (transl obj) (fun obj ->
         match kind, args with
@@ -878,7 +960,7 @@ let rec transl ulam =
   | Ulet(id, exp, body) ->
       begin match is_unboxed_number exp with
         No_unboxing ->
-          Clet(id, transl exp, transl body)
+          mk(Clet(id, transl exp, transl body))
       | Boxed_float ->
           transl_unbox_let box_float unbox_float transl_unbox_float
                            id exp body
@@ -893,31 +975,31 @@ let rec transl ulam =
   | Uprim(prim, args) ->
       begin match (simplif_primitive prim, args) with
         (Pgetglobal id, []) ->
-          Cconst_symbol (Ident.name id)
+          mk(Cconst_symbol (Ident.name id))
       | (Pmakeblock(tag, mut), []) ->
-          transl_constant(Const_block(tag, []))
+          transl_constant dbg (Const_block(tag, []))
       | (Pmakeblock(tag, mut), args) ->
-          make_alloc tag (List.map transl args)
+          make_alloc tag (List.map transl args) dbg
       | (Pccall prim, args) ->
           if prim.prim_native_float then
             box_float
-              (Cop(Cextcall(prim.prim_native_name, typ_float, false, dbg),
-                   List.map transl_unbox_float args))
+              (mk(Cop(Cextcall(prim.prim_native_name, typ_float, false),
+                      List.map transl_unbox_float args)))
           else
-            Cop(Cextcall(Primitive.native_name prim, typ_addr, prim.prim_alloc, dbg),
-                List.map transl args)
+            mk(Cop(Cextcall(Primitive.native_name prim, typ_addr, prim.prim_alloc),
+                   List.map transl args))
       | (Pmakearray kind, []) ->
-          transl_constant(Const_block(0, []))
+          transl_constant dbg (Const_block(0, []))
       | (Pmakearray kind, args) ->
           begin match kind with
             Pgenarray ->
-              Cop(Cextcall("caml_make_array", typ_addr, true, Debuginfo.none),
-                  [make_alloc 0 (List.map transl args)])
+              mk(Cop(Cextcall("caml_make_array", typ_addr, true),
+                     [make_alloc 0 (List.map transl args) dbg]))
           | Paddrarray | Pintarray ->
-              make_alloc 0 (List.map transl args)
+              make_alloc 0 (List.map transl args) dbg
           | Pfloatarray ->
               make_float_alloc Obj.double_array_tag
-                              (List.map transl_unbox_float args)
+                (List.map transl_unbox_float args) dbg
           end
       | (Pbigarrayref(unsafe, num_dims, elt_kind, layout), arg1 :: argl) ->
           let elt =
@@ -961,31 +1043,31 @@ let rec transl ulam =
       (* As in the bytecode interpreter, only matching against constants
          can be checked *)
       if Array.length s.us_index_blocks = 0 then
-        Cswitch
+        mk(Cswitch
           (untag_int (transl arg),
            s.us_index_consts,
-           Array.map transl s.us_actions_consts)
+           Array.map transl s.us_actions_consts))
       else if Array.length s.us_index_consts = 0 then
         transl_switch (get_tag (transl arg))
           s.us_index_blocks s.us_actions_blocks
       else
         bind "switch" (transl arg) (fun arg ->
-          Cifthenelse(
-          Cop(Cand, [arg; Cconst_int 1]),
-          transl_switch
-            (untag_int arg) s.us_index_consts s.us_actions_consts,
-          transl_switch
-            (get_tag arg) s.us_index_blocks s.us_actions_blocks))
+          mk(Cifthenelse(
+            mk(Cop(Cand, [arg; mk(Cconst_int 1)])),
+            transl_switch
+              (untag_int arg) s.us_index_consts s.us_actions_consts,
+            transl_switch
+              (get_tag arg) s.us_index_blocks s.us_actions_blocks)))
   | Ustaticfail (nfail, args) ->
-      Cexit (nfail, List.map transl args)
+      mk(Cexit (nfail, List.map transl args))
   | Ucatch(nfail, [], body, handler) ->
       make_catch nfail (transl body) (transl handler)
   | Ucatch(nfail, ids, body, handler) ->
-      Ccatch(nfail, ids, transl body, transl handler)
+      mk(Ccatch(nfail, ids, transl body, transl handler))
   | Utrywith(body, exn, handler) ->
-      Ctrywith(transl body, exn, transl handler)
-  | Uifthenelse({exp=Uprim(Pnot, [arg])}, ifso, ifnot) ->
-      transl (mk(Uifthenelse(arg, ifnot, ifso)))
+      mk(Ctrywith(transl body, exn, transl handler))
+  | Uifthenelse({exp=Uprim(Pnot, [arg])} as ul, ifso, ifnot) ->
+      transl {ul with exp=Uifthenelse(arg, ifnot, ifso)}
   | Uifthenelse(cond, ifso, {exp=Ustaticfail (nfail, [])}) ->
       exit_if_false cond (transl ifso) nfail
   | Uifthenelse(cond, {exp=Ustaticfail (nfail, [])}, ifnot) ->
@@ -1008,51 +1090,56 @@ let rec transl ulam =
         num_true
         (make_catch2
            (fun shared_false ->
-             Cifthenelse
-               (test_bool (transl cond),
-                exit_if_true condso num_true shared_false,
-                exit_if_true condnot num_true shared_false))
+             mk(Cifthenelse
+                  (test_bool (transl cond),
+                   exit_if_true condso num_true shared_false,
+                   exit_if_true condnot num_true shared_false)))
            (transl ifnot))
         (transl ifso)
   | Uifthenelse(cond, ifso, ifnot) ->
-      Cifthenelse(test_bool(transl cond), transl ifso, transl ifnot)
+      mk(Cifthenelse(test_bool(transl cond), transl ifso, transl ifnot))
   | Usequence(exp1, exp2) ->
-      Csequence(remove_unit(transl exp1), transl exp2)
+      mk(Csequence(remove_unit(transl exp1), transl exp2))
   | Uwhile(cond, body) ->
       let raise_num = next_raise_count () in
       return_unit
-        (Ccatch
+        (mk(Ccatch
            (raise_num, [],
-            Cloop(exit_if_false cond (remove_unit(transl body)) raise_num),
-            Ctuple []))
+            mk(Cloop(exit_if_false cond (remove_unit(transl body)) raise_num)),
+            mk(Ctuple []))))
   | Ufor(id, low, high, dir, body) ->
       let tst = match dir with Upto -> Cgt   | Downto -> Clt in
       let inc = match dir with Upto -> Caddi | Downto -> Csubi in
       let raise_num = next_raise_count () in
       let id_prev = Ident.rename id in
       return_unit
-        (Clet
-           (id, transl low,
-            bind_nonvar "bound" (transl high) (fun high ->
-              Ccatch
-                (raise_num, [],
-                 Cifthenelse
-                   (Cop(Ccmpi tst, [Cvar id; high]), Cexit (raise_num, []),
-                    Cloop
-                      (Csequence
-                         (remove_unit(transl body),
-                         Clet(id_prev, Cvar id,
-                          Csequence
-                            (Cassign(id,
-                               Cop(inc, [Cvar id; Cconst_int 2])),
-                             Cifthenelse
-                               (Cop(Ccmpi Ceq, [Cvar id_prev; high]),
-                                Cexit (raise_num,[]), Ctuple [])))))),
-                 Ctuple []))))
+        (mk(Clet
+          (id, transl low,
+           bind_nonvar "bound" (transl high) (fun high ->
+             mk(Ccatch
+               (raise_num, [],
+                mk(Cifthenelse
+                  (mk(Cop(Ccmpi tst, [mk(Cvar id); high])), mk(Cexit (raise_num, [])),
+                   mk(Cloop
+                     (mk(Csequence
+                        (remove_unit(transl body),
+                         mk(Clet
+                           (id_prev,
+                            mk(Cvar id),
+                            mk(Csequence
+                              (mk(Cassign
+                                 (id,
+                                  mk(Cop(inc, [mk(Cvar id); mk(Cconst_int 2)])))),
+                               mk(Cifthenelse
+                                 (mk(Cop(Ccmpi Ceq, [mk(Cvar id_prev); high])),
+                                  mk(Cexit (raise_num,[])),
+                                  mk(Ctuple []))))))))))))),
+                mk(Ctuple [])))))))
   | Uassign(id, exp) ->
-      return_unit(Cassign(id, transl exp))
+      return_unit(mk(Cassign(id, transl exp)))
 
 and transl_prim_1 p arg dbg =
+  let mk = mkdbg dbg in
   match p with
   (* Generic operations *)
     Pidentity ->
@@ -1065,34 +1152,34 @@ and transl_prim_1 p arg dbg =
   | Pfloatfield n ->
       let ptr = transl arg in
       box_float(
-        Cop(Cload Double_u,
+        mk(Cop(Cload Double_u,
             [if n = 0 then ptr
-                       else Cop(Cadda, [ptr; Cconst_int(n * size_float)])]))
+               else mk(Cop(Cadda, [ptr; mk(Cconst_int(n * size_float))]))])))
   (* Exceptions *)
   | Praise ->
-      Cop(Craise dbg, [transl arg])
+      mk(Cop(Craise, [transl arg]))
   (* Integer operations *)
   | Pnegint ->
-      Cop(Csubi, [Cconst_int 2; transl arg])
+      mk(Cop(Csubi, [mk(Cconst_int 2); transl arg]))
   | Poffsetint n ->
       if no_overflow_lsl n then
         add_const (transl arg) (n lsl 1)
       else
-        transl_prim_2 Paddint arg (mk(Uconst (Const_base(Const_int n)))) Debuginfo.none
+        transl_prim_2 Paddint arg (mkdbg dbg (Uconst (Const_base(Const_int n)))) dbg
   | Poffsetref n ->
       return_unit
         (bind "ref" (transl arg) (fun arg ->
-          Cop(Cstore Word,
-              [arg; add_const (Cop(Cload Word, [arg])) (n lsl 1)])))
+          mk(Cop(Cstore Word,
+              [arg; add_const (mk(Cop(Cload Word, [arg]))) (n lsl 1)]))))
   (* Floating-point operations *)
   | Pfloatofint ->
-      box_float(Cop(Cfloatofint, [untag_int(transl arg)]))
+      box_float(mk(Cop(Cfloatofint, [untag_int(transl arg)])))
   | Pintoffloat ->
-     tag_int(Cop(Cintoffloat, [transl_unbox_float arg]))
+     tag_int(mk(Cop(Cintoffloat, [transl_unbox_float arg])))
   | Pnegfloat ->
-      box_float(Cop(Cnegf, [transl_unbox_float arg]))
+      box_float(mk(Cop(Cnegf, [transl_unbox_float arg])))
   | Pabsfloat ->
-      box_float(Cop(Cabsf, [transl_unbox_float arg]))
+      box_float(mk(Cop(Cabsf, [transl_unbox_float arg])))
   (* String operations *)
   | Pstringlength ->
       tag_int(string_length (transl arg))
@@ -1102,24 +1189,24 @@ and transl_prim_1 p arg dbg =
         Pgenarray ->
           let len =
             if wordsize_shift = numfloat_shift then
-              Cop(Clsr, [header(transl arg); Cconst_int wordsize_shift])
+              mk(Cop(Clsr, [header(transl arg); mk(Cconst_int wordsize_shift)]))
             else
               bind "header" (header(transl arg)) (fun hdr ->
-                Cifthenelse(is_addr_array_hdr hdr,
-                            Cop(Clsr, [hdr; Cconst_int wordsize_shift]),
-                            Cop(Clsr, [hdr; Cconst_int numfloat_shift]))) in
-          Cop(Cor, [len; Cconst_int 1])
+                mk(Cifthenelse(is_addr_array_hdr hdr,
+                            mk(Cop(Clsr, [hdr; mk(Cconst_int wordsize_shift)])),
+                            mk(Cop(Clsr, [hdr; mk(Cconst_int numfloat_shift)]))))) in
+          mk(Cop(Cor, [len; mk(Cconst_int 1)]))
       | Paddrarray | Pintarray ->
-          Cop(Cor, [addr_array_length(header(transl arg)); Cconst_int 1])
+          mk(Cop(Cor, [addr_array_length(header(transl arg)); mk(Cconst_int 1)]))
       | Pfloatarray ->
-          Cop(Cor, [float_array_length(header(transl arg)); Cconst_int 1])
+          mk(Cop(Cor, [float_array_length(header(transl arg)); mk(Cconst_int 1)]))
       end
   (* Boolean operations *)
   | Pnot ->
-      Cop(Csubi, [Cconst_int 4; transl arg]) (* 1 -> 3, 3 -> 1 *)
+      mk(Cop(Csubi, [mk(Cconst_int 4); transl arg])) (* 1 -> 3, 3 -> 1 *)
   (* Test integer/block *)
   | Pisint ->
-      tag_int(Cop(Cand, [transl arg; Cconst_int 1]))
+      tag_int(mk(Cop(Cand, [transl arg; mk(Cconst_int 1)])))
   (* Boxed integers *)
   | Pbintofint bi ->
       box_int bi (untag_int (transl arg))
@@ -1128,35 +1215,36 @@ and transl_prim_1 p arg dbg =
   | Pcvtbint(bi1, bi2) ->
       box_int bi2 (transl_unbox_int bi1 arg)
   | Pnegbint bi ->
-      box_int bi (Cop(Csubi, [Cconst_int 0; transl_unbox_int bi arg]))
+      box_int bi (mk(Cop(Csubi, [mk(Cconst_int 0); transl_unbox_int bi arg])))
   | _ ->
       fatal_error "Cmmgen.transl_prim_1"
 
 and transl_prim_2 p arg1 arg2 dbg =
+  let mk = mkdbg dbg in
   match p with
   (* Heap operations *)
     Psetfield(n, ptr) ->
       if ptr then
-        return_unit(Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none),
-                        [field_address (transl arg1) n; transl arg2]))
+        return_unit(mk(Cop(Cextcall("caml_modify", typ_void, false),
+                           [field_address (transl arg1) n; transl arg2])))
       else
         return_unit(set_field (transl arg1) n (transl arg2))
   | Psetfloatfield n ->
       let ptr = transl arg1 in
       return_unit(
-        Cop(Cstore Double_u,
+        mk(Cop(Cstore Double_u,
             [if n = 0 then ptr
-                       else Cop(Cadda, [ptr; Cconst_int(n * size_float)]);
-                   transl_unbox_float arg2]))
+                       else mk(Cop(Cadda, [ptr; mk(Cconst_int(n * size_float))]));
+                   transl_unbox_float arg2])))
 
   (* Boolean operations *)
   | Psequand ->
-      Cifthenelse(test_bool(transl arg1), transl arg2, Cconst_int 1)
+      mk(Cifthenelse(test_bool(transl arg1), transl arg2, mk(Cconst_int 1)))
       (* let id = Ident.create "res1" in
       Clet(id, transl arg1,
            Cifthenelse(test_bool(Cvar id), transl arg2, Cvar id)) *)
   | Psequor ->
-      Cifthenelse(test_bool(transl arg1), Cconst_int 3, transl arg2)
+      mk(Cifthenelse(test_bool(transl arg1), mk(Cconst_int 3), transl arg2))
 
   (* Integer operations *)
   | Paddint ->
@@ -1164,59 +1252,59 @@ and transl_prim_2 p arg1 arg2 dbg =
   | Psubint ->
       incr_int(sub_int (transl arg1) (transl arg2))
   | Pmulint ->
-      incr_int(Cop(Cmuli, [decr_int(transl arg1); untag_int(transl arg2)]))
+      incr_int(mk(Cop(Cmuli, [decr_int(transl arg1); untag_int(transl arg2)])))
   | Pdivint ->
       tag_int(safe_divmod Cdivi (untag_int(transl arg1)) (untag_int(transl arg2)) dbg)
   | Pmodint ->
       tag_int(safe_divmod Cmodi (untag_int(transl arg1)) (untag_int(transl arg2)) dbg)
   | Pandint ->
-      Cop(Cand, [transl arg1; transl arg2])
+      mk(Cop(Cand, [transl arg1; transl arg2]))
   | Porint ->
-      Cop(Cor, [transl arg1; transl arg2])
+      mk(Cop(Cor, [transl arg1; transl arg2]))
   | Pxorint ->
-      Cop(Cor, [Cop(Cxor, [ignore_low_bit_int(transl arg1);
-                           ignore_low_bit_int(transl arg2)]);
-                Cconst_int 1])
+      mk(Cop(Cor, [mk(Cop(Cxor, [ignore_low_bit_int(transl arg1);
+                                 ignore_low_bit_int(transl arg2)]));
+                   mk(Cconst_int 1)]))
   | Plslint ->
       incr_int(lsl_int (decr_int(transl arg1)) (untag_int(transl arg2)))
   | Plsrint ->
-      Cop(Cor, [Cop(Clsr, [transl arg1; untag_int(transl arg2)]);
-                Cconst_int 1])
+    mk(Cop(Cor, [mk(Cop(Clsr, [transl arg1; untag_int(transl arg2)]));
+                 mk(Cconst_int 1)]))
   | Pasrint ->
-      Cop(Cor, [Cop(Casr, [transl arg1; untag_int(transl arg2)]);
-                Cconst_int 1])
+    mk(Cop(Cor, [mk(Cop(Casr, [transl arg1; untag_int(transl arg2)]));
+                 mk(Cconst_int 1)]))
   | Pintcomp cmp ->
-      tag_int(Cop(Ccmpi(transl_comparison cmp), [transl arg1; transl arg2]))
+      tag_int(mk(Cop(Ccmpi(transl_comparison cmp), [transl arg1; transl arg2])))
   | Pisout ->
       transl_isout (transl arg1) (transl arg2)
   (* Float operations *)
   | Paddfloat ->
-      box_float(Cop(Caddf,
-                    [transl_unbox_float arg1; transl_unbox_float arg2]))
+      box_float(mk(Cop(Caddf,
+                       [transl_unbox_float arg1; transl_unbox_float arg2])))
   | Psubfloat ->
-      box_float(Cop(Csubf,
-                    [transl_unbox_float arg1; transl_unbox_float arg2]))
+      box_float(mk(Cop(Csubf,
+                       [transl_unbox_float arg1; transl_unbox_float arg2])))
   | Pmulfloat ->
-      box_float(Cop(Cmulf,
-                    [transl_unbox_float arg1; transl_unbox_float arg2]))
+      box_float(mk(Cop(Cmulf,
+                       [transl_unbox_float arg1; transl_unbox_float arg2])))
   | Pdivfloat ->
-      box_float(Cop(Cdivf,
-                    [transl_unbox_float arg1; transl_unbox_float arg2]))
+      box_float(mk(Cop(Cdivf,
+                       [transl_unbox_float arg1; transl_unbox_float arg2])))
   | Pfloatcomp cmp ->
-      tag_int(Cop(Ccmpf(transl_comparison cmp),
-                  [transl_unbox_float arg1; transl_unbox_float arg2]))
+      tag_int(mk(Cop(Ccmpf(transl_comparison cmp),
+                     [transl_unbox_float arg1; transl_unbox_float arg2])))
 
   (* String operations *)
   | Pstringrefu ->
-      tag_int(Cop(Cload Byte_unsigned,
-                  [add_int (transl arg1) (untag_int(transl arg2))]))
+      tag_int(mk(Cop(Cload Byte_unsigned,
+                     [add_int (transl arg1) (untag_int(transl arg2))])))
   | Pstringrefs ->
       tag_int
         (bind "str" (transl arg1) (fun str ->
           bind "index" (untag_int (transl arg2)) (fun idx ->
-            Csequence(
-              Cop(Ccheckbound dbg, [string_length str; idx]),
-              Cop(Cload Byte_unsigned, [add_int str idx])))))
+            mk(Csequence(
+              mk(Cop(Ccheckbound, [string_length str; idx])),
+              mk(Cop(Cload Byte_unsigned, [add_int str idx])))))))
 
   (* Array operations *)
   | Parrayrefu kind ->
@@ -1224,9 +1312,9 @@ and transl_prim_2 p arg1 arg2 dbg =
         Pgenarray ->
           bind "arr" (transl arg1) (fun arr ->
             bind "index" (transl arg2) (fun idx ->
-              Cifthenelse(is_addr_array_ptr arr,
-                          addr_array_ref arr idx,
-                          float_array_ref arr idx)))
+              mk(Cifthenelse(is_addr_array_ptr arr,
+                             addr_array_ref arr idx,
+                             float_array_ref arr idx))))
       | Paddrarray | Pintarray ->
           addr_array_ref (transl arg1) (transl arg2)
       | Pfloatarray ->
@@ -1238,45 +1326,47 @@ and transl_prim_2 p arg1 arg2 dbg =
           bind "index" (transl arg2) (fun idx ->
             bind "arr" (transl arg1) (fun arr ->
               bind "header" (header arr) (fun hdr ->
-                Cifthenelse(is_addr_array_hdr hdr,
-                  Csequence(Cop(Ccheckbound dbg, [addr_array_length hdr; idx]),
-                            addr_array_ref arr idx),
-                  Csequence(Cop(Ccheckbound dbg, [float_array_length hdr; idx]),
-                            float_array_ref arr idx)))))
+                mk(Cifthenelse(is_addr_array_hdr hdr,
+                               mk(Csequence(mk(Cop(Ccheckbound, [addr_array_length hdr; idx])),
+                                            addr_array_ref arr idx)),
+                               mk(Csequence(mk(Cop(Ccheckbound, [float_array_length hdr; idx])),
+                                            float_array_ref arr idx)))))))
       | Paddrarray | Pintarray ->
           bind "index" (transl arg2) (fun idx ->
             bind "arr" (transl arg1) (fun arr ->
-              Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]),
-                        addr_array_ref arr idx)))
+              mk(Csequence
+                   (mk(Cop(Ccheckbound, [addr_array_length(header arr); idx])),
+                    addr_array_ref arr idx))))
       | Pfloatarray ->
           box_float(
             bind "index" (transl arg2) (fun idx ->
               bind "arr" (transl arg1) (fun arr ->
-                Csequence(Cop(Ccheckbound dbg,
-                              [float_array_length(header arr); idx]),
-                          unboxed_float_array_ref arr idx))))
+                mk(Csequence
+                     (mk(Cop(Ccheckbound, [float_array_length(header arr); idx])),
+                      unboxed_float_array_ref arr idx)))))
       end
 
   (* Operations on bitvects *)
   | Pbittest ->
       bind "index" (untag_int(transl arg2)) (fun idx ->
         tag_int(
-          Cop(Cand, [Cop(Clsr, [Cop(Cload Byte_unsigned,
-                                    [add_int (transl arg1)
-                                      (Cop(Clsr, [idx; Cconst_int 3]))]);
-                                Cop(Cand, [idx; Cconst_int 7])]);
-                     Cconst_int 1])))
+          mk(Cop(Cand, [mk(Cop(Clsr,
+                               [mk(Cop(Cload Byte_unsigned,
+                                       [add_int (transl arg1)
+                                           (mk(Cop(Clsr, [idx; mk(Cconst_int 3)])))]));
+                                mk(Cop(Cand, [idx; mk(Cconst_int 7)]))]));
+                        mk(Cconst_int 1)]))))
 
   (* Boxed integers *)
   | Paddbint bi ->
-      box_int bi (Cop(Caddi,
-                      [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
+      box_int bi (mk(Cop(Caddi,
+                         [transl_unbox_int bi arg1; transl_unbox_int bi arg2])))
   | Psubbint bi ->
-      box_int bi (Cop(Csubi,
-                      [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
+      box_int bi (mk(Cop(Csubi,
+                         [transl_unbox_int bi arg1; transl_unbox_int bi arg2])))
   | Pmulbint bi ->
-      box_int bi (Cop(Cmuli,
-                      [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
+      box_int bi (mk(Cop(Cmuli,
+                         [transl_unbox_int bi arg1; transl_unbox_int bi arg2])))
   | Pdivbint bi ->
       box_int bi (safe_divmod Cdivi
                       (transl_unbox_int bi arg1) (transl_unbox_int bi arg2)
@@ -1286,45 +1376,46 @@ and transl_prim_2 p arg1 arg2 dbg =
                       (transl_unbox_int bi arg1) (transl_unbox_int bi arg2)
                       dbg)
   | Pandbint bi ->
-      box_int bi (Cop(Cand,
-                     [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
+      box_int bi (mk(Cop(Cand,
+                         [transl_unbox_int bi arg1; transl_unbox_int bi arg2])))
   | Porbint bi ->
-      box_int bi (Cop(Cor,
-                     [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
+      box_int bi (mk(Cop(Cor,
+                         [transl_unbox_int bi arg1; transl_unbox_int bi arg2])))
   | Pxorbint bi ->
-      box_int bi (Cop(Cxor,
-                     [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
+      box_int bi (mk(Cop(Cxor,
+                         [transl_unbox_int bi arg1; transl_unbox_int bi arg2])))
   | Plslbint bi ->
-      box_int bi (Cop(Clsl,
-                     [transl_unbox_int bi arg1; untag_int(transl arg2)]))
+      box_int bi (mk(Cop(Clsl,
+                         [transl_unbox_int bi arg1; untag_int(transl arg2)])))
   | Plsrbint bi ->
-      box_int bi (Cop(Clsr,
-                     [make_unsigned_int bi (transl_unbox_int bi arg1);
-                      untag_int(transl arg2)]))
+      box_int bi (mk(Cop(Clsr,
+                         [make_unsigned_int bi (transl_unbox_int bi arg1);
+                          untag_int(transl arg2)])))
   | Pasrbint bi ->
-      box_int bi (Cop(Casr,
-                     [transl_unbox_int bi arg1; untag_int(transl arg2)]))
+      box_int bi (mk(Cop(Casr,
+                         [transl_unbox_int bi arg1; untag_int(transl arg2)])))
   | Pbintcomp(bi, cmp) ->
-      tag_int (Cop(Ccmpi(transl_comparison cmp),
-                     [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
+      tag_int (mk(Cop(Ccmpi(transl_comparison cmp),
+                      [transl_unbox_int bi arg1; transl_unbox_int bi arg2])))
   | _ ->
       fatal_error "Cmmgen.transl_prim_2"
 
 and transl_prim_3 p arg1 arg2 arg3 dbg =
+  let mk = mkdbg dbg in
   match p with
   (* String operations *)
     Pstringsetu ->
-      return_unit(Cop(Cstore Byte_unsigned,
-                      [add_int (transl arg1) (untag_int(transl arg2));
-                        untag_int(transl arg3)]))
+      return_unit(mk(Cop(Cstore Byte_unsigned,
+                         [add_int (transl arg1) (untag_int(transl arg2));
+                          untag_int(transl arg3)])))
   | Pstringsets ->
       return_unit
         (bind "str" (transl arg1) (fun str ->
           bind "index" (untag_int (transl arg2)) (fun idx ->
-            Csequence(
-              Cop(Ccheckbound dbg, [string_length str; idx]),
-              Cop(Cstore Byte_unsigned,
-                  [add_int str idx; untag_int(transl arg3)])))))
+            mk(Csequence(
+              mk(Cop(Ccheckbound, [string_length str; idx])),
+              mk(Cop(Cstore Byte_unsigned,
+                  [add_int str idx; untag_int(transl arg3)])))))))
 
   (* Array operations *)
   | Parraysetu kind ->
@@ -1333,9 +1424,9 @@ and transl_prim_3 p arg1 arg2 arg3 dbg =
           bind "newval" (transl arg3) (fun newval ->
             bind "index" (transl arg2) (fun index ->
               bind "arr" (transl arg1) (fun arr ->
-                Cifthenelse(is_addr_array_ptr arr,
-                            addr_array_set arr index newval,
-                            float_array_set arr index (unbox_float newval)))))
+                mk(Cifthenelse(is_addr_array_ptr arr,
+                               addr_array_set arr index newval,
+                               float_array_set arr index (unbox_float newval))))))
       | Paddrarray ->
           addr_array_set (transl arg1) (transl arg2) (transl arg3)
       | Pintarray ->
@@ -1350,46 +1441,53 @@ and transl_prim_3 p arg1 arg2 arg3 dbg =
             bind "index" (transl arg2) (fun idx ->
               bind "arr" (transl arg1) (fun arr ->
                 bind "header" (header arr) (fun hdr ->
-                  Cifthenelse(is_addr_array_hdr hdr,
-                    Csequence(Cop(Ccheckbound dbg, [addr_array_length hdr; idx]),
-                              addr_array_set arr idx newval),
-                    Csequence(Cop(Ccheckbound dbg, [float_array_length hdr; idx]),
-                              float_array_set arr idx
-                                              (unbox_float newval)))))))
+                  mk(Cifthenelse
+                       (is_addr_array_hdr hdr,
+                        mk(Csequence
+                          (mk(Cop(Ccheckbound, [addr_array_length hdr; idx])),
+                           addr_array_set arr idx newval)),
+                        mk(Csequence
+                          (mk(Cop(Ccheckbound, [float_array_length hdr; idx])),
+                           float_array_set arr idx (unbox_float newval)))))))))
       | Paddrarray ->
           bind "index" (transl arg2) (fun idx ->
             bind "arr" (transl arg1) (fun arr ->
-              Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]),
-                        addr_array_set arr idx (transl arg3))))
+              mk(Csequence
+                (mk(Cop(Ccheckbound,[addr_array_length(header arr); idx])),
+                 addr_array_set arr idx (transl arg3)))))
       | Pintarray ->
           bind "index" (transl arg2) (fun idx ->
             bind "arr" (transl arg1) (fun arr ->
-              Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]),
-                        int_array_set arr idx (transl arg3))))
+              mk(Csequence
+                (mk(Cop(Ccheckbound, [addr_array_length(header arr); idx])),
+                 int_array_set arr idx (transl arg3)))))
       | Pfloatarray ->
           bind "index" (transl arg2) (fun idx ->
             bind "arr" (transl arg1) (fun arr ->
-              Csequence(Cop(Ccheckbound dbg, [float_array_length(header arr);idx]),
-                        float_array_set arr idx (transl_unbox_float arg3))))
+              mk(Csequence
+                (mk(Cop(Ccheckbound, [float_array_length(header arr);idx])),
+                 float_array_set arr idx (transl_unbox_float arg3)))))
       end)
   | _ ->
     fatal_error "Cmmgen.transl_prim_3"
 
 and transl_unbox_float ulam =
+  let mk = mkdbg ulam.dbg in
   match ulam.exp with
-    Uconst(Const_base(Const_float f)) -> Cconst_float f
+    Uconst(Const_base(Const_float f)) -> mk(Cconst_float f)
   | _ -> unbox_float(transl ulam)
 
 and transl_unbox_int bi ulam =
+  let mk = mkdbg ulam.dbg in
   match ulam.exp with
     Uconst(Const_base(Const_int32 n)) ->
-      Cconst_natint (Nativeint.of_int32 n)
+      mk(Cconst_natint (Nativeint.of_int32 n))
   | Uconst(Const_base(Const_nativeint n)) ->
-      Cconst_natint n
+      mk(Cconst_natint n)
   | Uconst(Const_base(Const_int64 n)) ->
-      assert (size_int = 8); Cconst_natint (Int64.to_nativeint n)
+      assert (size_int = 8); mk(Cconst_natint (Int64.to_nativeint n))
   | Uprim(Pbintofint bi', [{exp=Uconst(Const_base(Const_int i))}]) when bi = bi' ->
-      Cconst_int i
+      mk(Cconst_int i)
   | _ -> unbox_int bi (transl ulam)
 
 and transl_unbox_let box_fn unbox_fn transl_unbox_fn id exp body =
@@ -1397,43 +1495,48 @@ and transl_unbox_let box_fn unbox_fn transl_unbox_fn id exp body =
   let trbody1 = transl body in
   let (trbody2, need_boxed, is_assigned) =
     subst_boxed_number unbox_fn id unboxed_id trbody1 in
+  let mk = mkdbg exp.dbg in
   if need_boxed && is_assigned then
-    Clet(id, transl exp, trbody1)
+    mk(Clet(id, transl exp, trbody1))
   else
-    Clet(unboxed_id, transl_unbox_fn exp,
-         if need_boxed
-         then Clet(id, box_fn(Cvar unboxed_id), trbody2)
-         else trbody2)
-
-and make_catch ncatch body handler = match body with
-| Cexit (nexit,[]) when nexit=ncatch -> handler
-| _ ->  Ccatch (ncatch, [], body, handler)
-
-and make_catch2 mk_body handler = match handler with
-| Cexit (_,[])|Ctuple []|Cconst_int _|Cconst_pointer _ ->
-    mk_body handler
-| _ ->
+    mk(Clet(unboxed_id, transl_unbox_fn exp,
+            if need_boxed
+            then mk(Clet(id, box_fn(mk(Cvar unboxed_id)), trbody2))
+            else trbody2))
+
+and make_catch ncatch body handler =
+  let mk = mkdbg body.dbg in
+  match body.exp with
+  | Cexit (nexit,[]) when nexit=ncatch -> handler
+  | _ ->  mk(Ccatch (ncatch, [], body, handler))
+
+and make_catch2 mk_body handler =
+  let mk = mkdbg handler.dbg in
+  match handler.exp with
+  | Cexit (_,[])|Ctuple []|Cconst_int _|Cconst_pointer _ -> mk_body handler
+  | _ ->
     let nfail = next_raise_count () in
     make_catch
       nfail
-      (mk_body (Cexit (nfail,[])))
+      (mk_body (mk(Cexit (nfail,[]))))
       handler
 
 and exit_if_true cond nfail otherwise =
+  let mk = mkdbg cond.dbg in
   match cond.exp with
   | Uconst (Const_pointer 0) -> otherwise
-  | Uconst (Const_pointer 1) -> Cexit (nfail,[])
+  | Uconst (Const_pointer 1) -> mk(Cexit (nfail,[]))
   | Uprim(Psequor, [arg1; arg2]) ->
       exit_if_true arg1 nfail (exit_if_true arg2 nfail otherwise)
   | Uprim(Psequand, _) ->
-      begin match otherwise with
+      begin match otherwise.exp with
       | Cexit (raise_num,[]) ->
-          exit_if_false cond (Cexit (nfail,[])) raise_num
+          exit_if_false cond (mk(Cexit (nfail,[]))) raise_num
       | _ ->
           let raise_num = next_raise_count () in
           make_catch
             raise_num
-            (exit_if_false cond (Cexit (nfail,[])) raise_num)
+            (exit_if_false cond (mk(Cexit (nfail,[]))) raise_num)
             otherwise
       end
   | Uprim(Pnot, [arg]) ->
@@ -1441,29 +1544,30 @@ and exit_if_true cond nfail otherwise =
   | Uifthenelse (cond, ifso, ifnot) ->
       make_catch2
         (fun shared ->
-          Cifthenelse
-            (test_bool (transl cond),
-             exit_if_true ifso nfail shared,
-             exit_if_true ifnot nfail shared))
+          mk(Cifthenelse
+               (test_bool (transl cond),
+                exit_if_true ifso nfail shared,
+                exit_if_true ifnot nfail shared)))
         otherwise
   | _ ->
-      Cifthenelse(test_bool(transl cond), Cexit (nfail, []), otherwise)
+      mk(Cifthenelse(test_bool(transl cond), mk(Cexit (nfail, [])), otherwise))
 
 and exit_if_false cond otherwise nfail =
+  let mk = mkdbg cond.dbg in
   match cond.exp with
-  | Uconst (Const_pointer 0) -> Cexit (nfail,[])
+  | Uconst (Const_pointer 0) -> mk(Cexit (nfail,[]))
   | Uconst (Const_pointer 1) -> otherwise
   | Uprim(Psequand, [arg1; arg2]) ->
       exit_if_false arg1 (exit_if_false arg2 otherwise nfail) nfail
   | Uprim(Psequor, _) ->
-      begin match otherwise with
+      begin match otherwise.exp with
       | Cexit (raise_num,[]) ->
-          exit_if_true cond raise_num (Cexit (nfail,[]))
+          exit_if_true cond raise_num (mk(Cexit (nfail,[])))
       | _ ->
           let raise_num = next_raise_count () in
           make_catch
             raise_num
-            (exit_if_true cond raise_num (Cexit (nfail,[])))
+            (exit_if_true cond raise_num (mk(Cexit (nfail,[]))))
             otherwise
       end
   | Uprim(Pnot, [arg]) ->
@@ -1471,13 +1575,13 @@ and exit_if_false cond otherwise nfail =
   | Uifthenelse (cond, ifso, ifnot) ->
       make_catch2
         (fun shared ->
-          Cifthenelse
-            (test_bool (transl cond),
-             exit_if_false ifso shared nfail,
-             exit_if_false ifnot shared nfail))
+          mk(Cifthenelse
+               (test_bool (transl cond),
+                exit_if_false ifso shared nfail,
+                exit_if_false ifnot shared nfail)))
         otherwise
   | _ ->
-      Cifthenelse(test_bool(transl cond), otherwise, Cexit (nfail, []))
+      mk(Cifthenelse(test_bool(transl cond), otherwise, mk(Cexit (nfail, []))))
 
 and transl_switch arg index cases = match Array.length cases with
 | 0 -> fatal_error "Cmmgen.transl_switch"
@@ -1506,7 +1610,7 @@ and transl_switch arg index cases = match Array.length cases with
       (fun a ->
         SwitcherBlocks.zyva
           (0,n_index-1)
-          (fun i -> Cconst_int i)
+          (fun i -> mkdbg arg.dbg (Cconst_int i))
           a
           (Array.of_list !inters) actions)
 
@@ -1515,22 +1619,23 @@ and transl_letrec bindings cont =
   let rec init_blocks = function
     | [] -> fill_nonrec bsz
     | (id, exp, RHS_block sz) :: rem ->
-        Clet(id, Cop(Cextcall("caml_alloc_dummy", typ_addr, true, Debuginfo.none),
-                     [int_const sz]),
-             init_blocks rem)
+        mk(Clet
+             (id,
+              mk(Cop(Cextcall("caml_alloc_dummy", typ_addr, true), [mk(int_const sz)])),
+              init_blocks rem))
     | (id, exp, RHS_nonrec) :: rem ->
-        Clet (id, Cconst_int 0, init_blocks rem)
+        mk(Clet (id, mk(Cconst_int 0), init_blocks rem))
   and fill_nonrec = function
     | [] -> fill_blocks bsz
     | (id, exp, RHS_block sz) :: rem -> fill_nonrec rem
     | (id, exp, RHS_nonrec) :: rem ->
-        Clet (id, transl exp, fill_nonrec rem)
+        mk(Clet (id, transl exp, fill_nonrec rem))
   and fill_blocks = function
     | [] -> cont
     | (id, exp, RHS_block _) :: rem ->
-        Csequence(Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none),
-                      [Cvar id; transl exp]),
-                  fill_blocks rem)
+        mk(Csequence
+             (mk(Cop(Cextcall("caml_update_dummy", typ_void, false), [mk(Cvar id); transl exp])),
+              fill_blocks rem))
     | (id, exp, RHS_nonrec) :: rem ->
         fill_blocks rem
   in init_blocks bsz
@@ -1769,37 +1874,37 @@ let cache_public_method meths tag cache =
   let raise_num = next_raise_count () in
   let li = Ident.create "li" and hi = Ident.create "hi"
   and mi = Ident.create "mi" and tagged = Ident.create "tagged" in
-  Clet (
-  li, Cconst_int 3,
-  Clet (
-  hi, Cop(Cload Word, [meths]),
-  Csequence(
-  Ccatch
+  mk(Clet (
+  li, mk(Cconst_int 3),
+  mk(Clet (
+  hi, mk(Cop(Cload Word, [meths])),
+  mk(Csequence(
+  mk(Ccatch
     (raise_num, [],
-     Cloop
-       (Clet(
+     mk(Cloop
+       (mk(Clet(
         mi,
-        Cop(Cor,
-            [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi]); Cconst_int 1]);
-             Cconst_int 1]),
-        Csequence(
-        Cifthenelse
-          (Cop (Ccmpi Clt,
+        mk(Cop(Cor,
+            [mk(Cop(Clsr, [mk(Cop(Caddi, [mk(Cvar li); mk(Cvar hi)])); mk(Cconst_int 1)]));
+             mk(Cconst_int 1)])),
+        mk(Csequence(
+        mk(Cifthenelse
+          (mk(Cop (Ccmpi Clt,
                 [tag;
-                 Cop(Cload Word,
-                     [Cop(Cadda,
-                          [meths; lsl_const (Cvar mi) log2_size_addr])])]),
-           Cassign(hi, Cop(Csubi, [Cvar mi; Cconst_int 2])),
-           Cassign(li, Cvar mi)),
-        Cifthenelse
-          (Cop(Ccmpi Cge, [Cvar li; Cvar hi]), Cexit (raise_num, []),
-           Ctuple [])))),
-     Ctuple []),
-  Clet (
-  tagged, Cop(Cadda, [lsl_const (Cvar li) log2_size_addr;
-                      Cconst_int(1 - 3 * size_addr)]),
-  Csequence(Cop (Cstore Word, [cache; Cvar tagged]),
-            Cvar tagged)))))
+                 mk(Cop(Cload Word,
+                     [mk(Cop(Cadda,
+                          [meths; lsl_const (mk(Cvar mi)) log2_size_addr]))]))])),
+           mk(Cassign(hi, mk(Cop(Csubi, [mk(Cvar mi); mk(Cconst_int 2)])))),
+           mk(Cassign(li, mk(Cvar mi))))),
+        mk(Cifthenelse
+          (mk(Cop(Ccmpi Cge, [mk(Cvar li); mk(Cvar hi)])), mk(Cexit (raise_num, [])),
+           mk(Ctuple []))))))))),
+     mk(Ctuple []))),
+  mk(Clet (
+  tagged, mk(Cop(Cadda, [lsl_const (mk(Cvar li)) log2_size_addr;
+                      mk(Cconst_int(1 - 3 * size_addr))])),
+  mk(Csequence(mk(Cop (Cstore Word, [cache; mk(Cvar tagged)])),
+               mk(Cvar tagged)))))))))))
 
 (* Generate an application function:
      (defun caml_applyN (a1 ... aN clos)
@@ -1818,24 +1923,24 @@ let apply_function_body arity =
   let clos = Ident.create "clos" in
   let rec app_fun clos n =
     if n = arity-1 then
-      Cop(Capply(typ_addr, Debuginfo.none),
-          [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos])
+      mk(Cop(Capply typ_addr,
+          [get_field (mk(Cvar clos)) 0; mk(Cvar arg.(n)); mk(Cvar clos)]))
     else begin
       let newclos = Ident.create "clos" in
-      Clet(newclos,
-           Cop(Capply(typ_addr, Debuginfo.none),
-               [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos]),
-           app_fun newclos (n+1))
+      mk(Clet(newclos,
+           mk(Cop(Capply typ_addr,
+                  [get_field (mk(Cvar clos)) 0; mk(Cvar arg.(n)); mk(Cvar clos)])),
+              app_fun newclos (n+1)))
     end in
   let args = Array.to_list arg in
   let all_args = args @ [clos] in
   (args, clos,
    if arity = 1 then app_fun clos 0 else
-   Cifthenelse(
-   Cop(Ccmpi Ceq, [get_field (Cvar clos) 1; int_const arity]),
-   Cop(Capply(typ_addr, Debuginfo.none),
-       get_field (Cvar clos) 2 :: List.map (fun s -> Cvar s) all_args),
-   app_fun clos 0))
+   mk(Cifthenelse(
+   mk(Cop(Ccmpi Ceq, [get_field (mk(Cvar clos)) 1; mk(int_const arity)])),
+   mk(Cop(Capply typ_addr,
+      get_field (mk(Cvar clos)) 2 :: List.map (fun s -> mk(Cvar s)) all_args)),
+   app_fun clos 0)))
 
 let send_function arity =
   let (args, clos', body) = apply_function_body (1+arity) in
@@ -1843,28 +1948,31 @@ let send_function arity =
   and obj = List.hd args
   and tag = Ident.create "tag" in
   let clos =
-    let cache = Cvar cache and obj = Cvar obj and tag = Cvar tag in
+    let cache = mk(Cvar cache)
+    and obj = mk(Cvar obj)
+    and tag = mk(Cvar tag) in
     let meths = Ident.create "meths" and cached = Ident.create "cached" in
     let real = Ident.create "real" in
-    let mask = get_field (Cvar meths) 1 in
-    let cached_pos = Cvar cached in
-    let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths]);
-                              Cconst_int(3*size_addr-1)]) in
-    let tag' = Cop(Cload Word, [tag_pos]) in
-    Clet (
-    meths, Cop(Cload Word, [obj]),
-    Clet (
-    cached, Cop(Cand, [Cop(Cload Word, [cache]); mask]),
-    Clet (
+    let mask = get_field (mk(Cvar meths)) 1 in
+    let cached_pos = mk(Cvar cached) in
+    let tag_pos = mk(Cop(Cadda, [mk(Cop (Cadda, [cached_pos; mk(Cvar meths)]));
+                                 mk(Cconst_int(3*size_addr-1))])) in
+    let tag' = mk(Cop(Cload Word, [tag_pos])) in
+    mk(Clet (
+    meths, mk(Cop(Cload Word, [obj])),
+    mk(Clet (
+    cached, mk(Cop(Cand, [mk(Cop(Cload Word, [cache])); mask])),
+    mk(Clet (
     real,
-    Cifthenelse(Cop(Ccmpa Cne, [tag'; tag]),
-                cache_public_method (Cvar meths) tag cache,
-                cached_pos),
-    Cop(Cload Word, [Cop(Cadda, [Cop (Cadda, [Cvar real; Cvar meths]);
-                                 Cconst_int(2*size_addr-1)])]))))
-
+    mk(Cifthenelse(mk(Cop(Ccmpa Cne, [tag'; tag])),
+                   cache_public_method (mk(Cvar meths)) tag cache,
+                   cached_pos)),
+    mk(Cop(Cload Word,
+           [mk(Cop(Cadda,
+                   [mk(Cop (Cadda, [mk(Cvar real); mk(Cvar meths)]));
+                    mk(Cconst_int(2*size_addr-1))]))]))))))))
   in
-  let body = Clet(clos', clos, body) in
+  let body = mk(Clet(clos', clos, body)) in
   let fun_args =
     [obj, typ_addr; tag, typ_int; cache, typ_addr]
     @ List.map (fun id -> (id, typ_addr)) (List.tl args) in
@@ -1895,13 +2003,13 @@ let tuplify_function arity =
   let rec access_components i =
     if i >= arity
     then []
-    else get_field (Cvar arg) i :: access_components(i+1) in
+    else get_field (mk(Cvar arg)) i :: access_components(i+1) in
   Cfunction
    {fun_name = "caml_tuplify" ^ string_of_int arity;
     fun_args = [arg, typ_addr; clos, typ_addr];
     fun_body =
-      Cop(Capply(typ_addr, Debuginfo.none),
-          get_field (Cvar clos) 2 :: access_components 0 @ [Cvar clos]);
+      mk(Cop(Capply typ_addr,
+             get_field (mk(Cvar clos)) 2 :: access_components 0 @ [mk(Cvar clos)]));
     fun_fast = true;
     fun_dbg  = Debuginfo.none }
 
@@ -1925,14 +2033,14 @@ let final_curry_function arity =
   let last_clos = Ident.create "clos" in
   let rec curry_fun args clos n =
     if n = 0 then
-      Cop(Capply(typ_addr, Debuginfo.none),
-          get_field (Cvar clos) 2 ::
-          args @ [Cvar last_arg; Cvar clos])
+      mk(Cop(Capply typ_addr,
+             get_field (mk(Cvar clos)) 2 ::
+               args @ [mk(Cvar last_arg); mk(Cvar clos)]))
     else begin
       let newclos = Ident.create "clos" in
-      Clet(newclos,
-           get_field (Cvar clos) 3,
-           curry_fun (get_field (Cvar clos) 2 :: args) newclos (n-1))
+      mk(Clet(newclos,
+           get_field (mk(Cvar clos)) 3,
+           curry_fun (get_field (mk(Cvar clos)) 2 :: args) newclos (n-1)))
     end in
   Cfunction
    {fun_name = "caml_curry" ^ string_of_int arity ^
@@ -1952,10 +2060,10 @@ let rec intermediate_curry_functions arity num =
     Cfunction
      {fun_name = name2;
       fun_args = [arg, typ_addr; clos, typ_addr];
-      fun_body = Cop(Calloc,
-                     [alloc_closure_header 4;
-                      Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1));
-                      int_const 1; Cvar arg; Cvar clos]);
+      fun_body = mk(Cop(Calloc,
+                        [mk(alloc_closure_header 4);
+                         mk(Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)));
+                         mk(int_const 1); mk(Cvar arg); mk(Cvar clos)]));
       fun_fast = true;
       fun_dbg  = Debuginfo.none }
     :: intermediate_curry_functions arity (num+1)
@@ -1995,18 +2103,18 @@ let generic_functions shared units =
 
 let entry_point namelist =
   let incr_global_inited =
-    Cop(Cstore Word,
-        [Cconst_symbol "caml_globals_inited";
-         Cop(Caddi, [Cop(Cload Word, [Cconst_symbol "caml_globals_inited"]);
-                     Cconst_int 1])]) in
+    mk(Cop(Cstore Word,
+           [mk(Cconst_symbol "caml_globals_inited");
+            mk(Cop(Caddi, [mk(Cop(Cload Word, [mk(Cconst_symbol "caml_globals_inited")]));
+                           mk(Cconst_int 1)]))])) in
   let body =
     List.fold_right
       (fun name next ->
         let entry_sym = Compilenv.make_symbol ~unitname:name (Some "entry") in
-        Csequence(Cop(Capply(typ_void, Debuginfo.none),
-                         [Cconst_symbol entry_sym]),
-                  Csequence(incr_global_inited, next)))
-      namelist (Cconst_int 1) in
+        mk(Csequence(mk(Cop(Capply typ_void,
+                            [mk(Cconst_symbol entry_sym)])),
+                     mk(Csequence(incr_global_inited, next)))))
+      namelist (mk(Cconst_int 1)) in
   Cfunction {fun_name = "caml_program";
              fun_args = [];
              fun_body = body;
diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml
index 2491bdb..737b774 100644
--- a/asmcomp/printcmm.ml
+++ b/asmcomp/printcmm.ml
@@ -16,6 +16,7 @@
 
 open Format
 open Cmm
+open Debuginfo
 
 let machtype_component ppf = function
   | Addr -> fprintf ppf "addr"
@@ -51,9 +52,9 @@ let chunk = function
   | Double_u -> "float64u"
 
 let operation = function
-  | Capply(ty, d) -> "app" ^ Debuginfo.string_of_dbg d
-  | Cextcall(lbl, ty, alloc, d) ->
-      Printf.sprintf "extcall \"%s\"%s" lbl (Debuginfo.string_of_dbg d)
+  | Capply(ty) -> "app"
+  | Cextcall(lbl, ty, alloc) ->
+      Printf.sprintf "extcall \"%s\"" lbl
   | Cload Word -> "load"
   | Cload c -> Printf.sprintf "load %s" (chunk c)
   | Calloc -> "alloc"
@@ -83,10 +84,10 @@ let operation = function
   | Cfloatofint -> "floatofint"
   | Cintoffloat -> "intoffloat"
   | Ccmpf c -> Printf.sprintf "%sf" (comparison c)
-  | Craise d -> "raise" ^ Debuginfo.string_of_dbg d
-  | Ccheckbound d -> "checkbound" ^ Debuginfo.string_of_dbg d
+  | Craise -> "raise"
+  | Ccheckbound -> "checkbound"
 
-let rec expr ppf = function
+let rec expr_desc ppf = function
   | Cconst_int n -> fprintf ppf "%i" n
   | Cconst_natint n -> fprintf ppf "%s" (Nativeint.to_string n)
   | Cconst_float s -> fprintf ppf "%s" s
@@ -94,45 +95,45 @@ let rec expr ppf = function
   | Cconst_pointer n -> fprintf ppf "%ia" n
   | Cconst_natpointer n -> fprintf ppf "%sa" (Nativeint.to_string n)
   | Cvar id -> Ident.print ppf id
-  | Clet(id, def, (Clet(_, _, _) as body)) ->
+  | Clet(id, def, ({exp=Clet(_, _, _)} as body)) ->
       let print_binding id ppf def =
-        fprintf ppf "@[<2>%a@ %a@]" Ident.print id expr def in
-      let rec in_part ppf = function
+        fprintf ppf "@[<2>%a@ %a@]" Ident.print id expression def in
+      let rec in_part ppf cmm = match cmm.exp with
         | Clet(id, def, body) ->
             fprintf ppf "@ %a" (print_binding id) def;
             in_part ppf body
-        | exp -> exp in
+        | _ -> cmm in
       fprintf ppf "@[<2>(let@ @[<1>(%a" (print_binding id) def;
       let exp = in_part ppf body in
       fprintf ppf ")@]@ %a)@]" sequence exp
   | Clet(id, def, body) ->
      fprintf ppf
       "@[<2>(let@ @[<2>%a@ %a@]@ %a)@]"
-      Ident.print id expr def sequence body
+      Ident.print id expression def sequence body
   | Cassign(id, exp) ->
-      fprintf ppf "@[<2>(assign @[<2>%a@ %a@])@]" Ident.print id expr exp
+      fprintf ppf "@[<2>(assign @[<2>%a@ %a@])@]" Ident.print id expression exp
   | Ctuple el ->
       let tuple ppf el =
        let first = ref true in
        List.iter
         (fun e ->
           if !first then first := false else fprintf ppf "@ ";
-          expr ppf e)
+          expression ppf e)
         el in
       fprintf ppf "@[<1>[%a]@]" tuple el
   | Cop(op, el) ->
       fprintf ppf "@[<2>(%s" (operation op);
-      List.iter (fun e -> fprintf ppf "@ %a" expr e) el;
+      List.iter (fun e -> fprintf ppf "@ %a" expression e) el;
       begin match op with
-      | Capply (mty, _) -> fprintf ppf "@ %a" machtype mty
-      | Cextcall(_, mty, _, _) -> fprintf ppf "@ %a" machtype mty
+      | Capply mty -> fprintf ppf "@ %a" machtype mty
+      | Cextcall(_, mty, _) -> fprintf ppf "@ %a" machtype mty
       | _ -> ()
       end;
       fprintf ppf ")@]"
   | Csequence(e1, e2) ->
       fprintf ppf "@[<2>(seq@ %a@ %a)@]" sequence e1 sequence e2
   | Cifthenelse(e1, e2, e3) ->
-      fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" expr e1 expr e2 expr e3
+      fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" expression e1 expression e2 expression e3
   | Cswitch(e1, index, cases) ->
       let print_case i ppf =
         for j = 0 to Array.length index - 1 do
@@ -142,7 +143,7 @@ let rec expr ppf = function
        for i = 0 to Array.length cases - 1 do
         fprintf ppf "@ @[<2>%t@ %a@]" (print_case i) sequence cases.(i)
        done in
-      fprintf ppf "@[<v 0>@[<2>(switch@ %a@ @]%t)@]" expr e1 print_cases
+      fprintf ppf "@[<v 0>@[<2>(switch@ %a@ @]%t)@]" expression e1 print_cases
   | Cloop e ->
       fprintf ppf "@[<2>(loop@ %a)@]" sequence e
   | Ccatch(i, ids, e1, e2) ->
@@ -156,17 +157,21 @@ let rec expr ppf = function
         sequence e2
   | Cexit (i, el) ->
       fprintf ppf "@[<2>(exit %d" i ;
-      List.iter (fun e -> fprintf ppf "@ %a" expr e) el;
+      List.iter (fun e -> fprintf ppf "@ %a" expression e) el;
       fprintf ppf ")@]"
   | Ctrywith(e1, id, e2) ->
       fprintf ppf "@[<2>(try@ %a@;<1 -2>with@ %a@ %a)@]"
              sequence e1 Ident.print id sequence e2
 
-and sequence ppf = function
+and sequence ppf cmm = match cmm.exp with
   | Csequence(e1, e2) -> fprintf ppf "%a@ %a" sequence e1 sequence e2
-  | e -> expression ppf e
+  | _ -> expression ppf cmm
 
-and expression ppf e = fprintf ppf "%a" expr e
+and expression ppf e =
+  if Debuginfo.is_none e.dbg then
+    fprintf ppf "%a" expr_desc e.exp
+  else
+    fprintf ppf "%s:%a" (Debuginfo.string_of_dbg e.dbg) expr_desc e.exp
 
 let fundecl ppf f =
   let print_cases ppf cases =
@@ -176,8 +181,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 Debuginfo.is_none f.fun_dbg then
+      ""
+    else
+      Debuginfo.string_of_dbg f.fun_dbg ^ ":" in
+  fprintf ppf "@[<1>(function %s%s@;<1 4>@[<1>(%a)@]@ @[%a@])@]@."
+         dbg f.fun_name print_cases f.fun_args sequence f.fun_body
 
 let data_item ppf = function
   | Cdefine_symbol s -> fprintf ppf "\"%s\":" s
diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
index 0952324..2f88d37 100644
--- a/asmcomp/selectgen.ml
+++ b/asmcomp/selectgen.ml
@@ -19,14 +19,15 @@ open Misc
 open Cmm
 open Reg
 open Mach
+open Debuginfo
 
 type environment = (Ident.t, Reg.t array) Tbl.t
 
 (* Infer the type of the result of an operation *)
 
 let oper_result_type = function
-    Capply(ty, _) -> ty
-  | Cextcall(s, ty, alloc, _) -> ty
+    Capply ty -> ty
+  | Cextcall(s, ty, alloc) -> ty
   | Cload c ->
       begin match c with
         Word -> typ_addr
@@ -42,13 +43,13 @@ let oper_result_type = function
   | Cnegf | Cabsf | Caddf | Csubf | Cmulf | Cdivf -> typ_float
   | Cfloatofint -> typ_float
   | Cintoffloat -> typ_int
-  | Craise _ -> typ_void
-  | Ccheckbound _ -> typ_void
+  | Craise -> typ_void
+  | Ccheckbound -> typ_void
 
 (* Infer the size in bytes of the result of a simple expression *)
 
 let size_expr env exp =
-  let rec size localenv = function
+  let rec size localenv c = match c.exp with
       Cconst_int _ | Cconst_natint _ -> Arch.size_int
     | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ ->
         Arch.size_addr
@@ -105,6 +106,7 @@ let name_regs id rv =
    in the same registers. *)
 
 let join opt_r1 seq1 opt_r2 seq2 =
+  let dbg = Debuginfo.none in
   match (opt_r1, opt_r2) with
     (None, _) -> opt_r2
   | (_, None) -> opt_r1
@@ -115,14 +117,14 @@ let join opt_r1 seq1 opt_r2 seq2 =
       for i = 0 to l1-1 do
         if String.length r1.(i).name = 0 then begin
           r.(i) <- r1.(i);
-          seq2#insert_move r2.(i) r1.(i)
+          seq2#insert_move dbg r2.(i) r1.(i)
         end else if String.length r2.(i).name = 0 then begin
           r.(i) <- r2.(i);
-          seq1#insert_move r1.(i) r2.(i)
+          seq1#insert_move dbg r1.(i) r2.(i)
         end else begin
           r.(i) <- Reg.create r1.(i).typ;
-          seq1#insert_move r1.(i) r.(i);
-          seq2#insert_move r2.(i) r.(i)
+          seq1#insert_move dbg r1.(i) r.(i);
+          seq2#insert_move dbg r2.(i) r.(i)
         end
       done;
       Some r
@@ -147,18 +149,10 @@ let join_array rs =
         let (r, s) = rs.(i) in
         match r with
           None -> ()
-        | Some r -> s#insert_moves r res
+        | Some r -> s#insert_moves Debuginfo.none r res
       done;
       Some res
 
-(* Extract debug info contained in a C-- operation *)
-let debuginfo_op = function
-  | Capply(_, dbg) -> dbg
-  | Cextcall(_, _, _, dbg) -> dbg
-  | Craise dbg -> dbg
-  | Ccheckbound dbg -> dbg
-  | _ -> Debuginfo.none
-
 (* Registers for catch constructs *)
 let catch_regs = ref []
 
@@ -176,7 +170,7 @@ class virtual selector_generic = object (self)
    first, then the block is allocated, then the simple arguments are
    evaluated and stored. *)
 
-method is_simple_expr = function
+method is_simple_expr c = match c.exp with
     Cconst_int _ -> true
   | Cconst_natint _ -> true
   | Cconst_float _ -> true
@@ -190,7 +184,7 @@ method is_simple_expr = function
   | Cop(op, args) ->
       begin match op with
         (* The following may have side effects *)
-      | Capply _ | Cextcall _ | Calloc | Cstore _ | Craise _ -> false
+      | Capply _ | Cextcall _ | Calloc | Cstore _ | Craise -> false
         (* The remaining operations are simple if their args are *)
       | _ ->
           List.for_all self#is_simple_expr args
@@ -215,9 +209,9 @@ method select_store addr arg =
 
 method select_operation op args =
   match (op, args) with
-    (Capply(ty, dbg), Cconst_symbol s :: rem) -> (Icall_imm s, rem)
-  | (Capply(ty, dbg), _) -> (Icall_ind, args)
-  | (Cextcall(s, ty, alloc, dbg), _) -> (Iextcall(s, alloc), args)
+    (Capply ty, {exp=Cconst_symbol s} :: rem) -> (Icall_imm s, rem)
+  | (Capply ty, _) -> (Icall_ind, args)
+  | (Cextcall(s, ty, alloc), _) -> (Iextcall(s, alloc), args)
   | (Cload chunk, [arg]) ->
       let (addr, eloc) = self#select_addressing arg in
       (Iload(chunk, addr), [eloc])
@@ -233,12 +227,12 @@ method select_operation op args =
   | (Calloc, _) -> (Ialloc 0, args)
   | (Caddi, _) -> self#select_arith_comm Iadd args
   | (Csubi, _) -> self#select_arith Isub args
-  | (Cmuli, [arg1; Cconst_int n]) ->
+  | (Cmuli, [arg1; {exp=Cconst_int n}]) ->
       let l = Misc.log2 n in
       if n = 1 lsl l
       then (Iintop_imm(Ilsl, l), [arg1])
       else self#select_arith_comm Imul args
-  | (Cmuli, [Cconst_int n; arg1]) ->
+  | (Cmuli, [{exp=Cconst_int n}; arg1]) ->
       let l = Misc.log2 n in
       if n = 1 lsl l
       then (Iintop_imm(Ilsl, l), [arg1])
@@ -264,76 +258,78 @@ method select_operation op args =
   | (Cdivf, _) -> (Idivf, args)
   | (Cfloatofint, _) -> (Ifloatofint, args)
   | (Cintoffloat, _) -> (Iintoffloat, args)
-  | (Ccheckbound _, _) -> self#select_arith Icheckbound args
+  | (Ccheckbound, _) -> self#select_arith Icheckbound args
   | _ -> fatal_error "Selection.select_oper"
 
 method private select_arith_comm op = function
-    [arg; Cconst_int n] when self#is_immediate n ->
+    [arg; {exp=Cconst_int n}] when self#is_immediate n ->
       (Iintop_imm(op, n), [arg])
-  | [arg; Cconst_pointer n] when self#is_immediate n ->
+  | [arg; {exp=Cconst_pointer n}] when self#is_immediate n ->
       (Iintop_imm(op, n), [arg])
-  | [Cconst_int n; arg] when self#is_immediate n ->
+  | [{exp=Cconst_int n}; arg] when self#is_immediate n ->
       (Iintop_imm(op, n), [arg])
-  | [Cconst_pointer n; arg] when self#is_immediate n ->
+  | [{exp=Cconst_pointer n}; arg] when self#is_immediate n ->
       (Iintop_imm(op, n), [arg])
   | args ->
       (Iintop op, args)
 
 method private select_arith op = function
-    [arg; Cconst_int n] when self#is_immediate n ->
+    [arg; {exp=Cconst_int n}] when self#is_immediate n ->
       (Iintop_imm(op, n), [arg])
-  | [arg; Cconst_pointer n] when self#is_immediate n ->
+  | [arg; {exp=Cconst_pointer n}] when self#is_immediate n ->
       (Iintop_imm(op, n), [arg])
   | args ->
       (Iintop op, args)
 
 method private select_shift op = function
-    [arg; Cconst_int n] when n >= 0 && n < Arch.size_int * 8 ->
+    [arg; {exp=Cconst_int n}] when n >= 0 && n < Arch.size_int * 8 ->
       (Iintop_imm(op, n), [arg])
   | args ->
       (Iintop op, args)
 
 method private select_arith_comp cmp = function
-    [arg; Cconst_int n] when self#is_immediate n ->
+    [arg; {exp=Cconst_int n}] when self#is_immediate n ->
       (Iintop_imm(Icomp cmp, n), [arg])
-  | [arg; Cconst_pointer n] when self#is_immediate n ->
+  | [arg; {exp=Cconst_pointer n}] when self#is_immediate n ->
       (Iintop_imm(Icomp cmp, n), [arg])
-  | [Cconst_int n; arg] when self#is_immediate n ->
+  | [{exp=Cconst_int n}; arg] when self#is_immediate n ->
       (Iintop_imm(Icomp(swap_intcomp cmp), n), [arg])
-  | [Cconst_pointer n; arg] when self#is_immediate n ->
+  | [{exp=Cconst_pointer n}; arg] when self#is_immediate n ->
       (Iintop_imm(Icomp(swap_intcomp cmp), n), [arg])
   | args ->
       (Iintop(Icomp cmp), args)
 
 (* Instruction selection for conditionals *)
 
-method select_condition = function
-    Cop(Ccmpi cmp, [arg1; Cconst_int n]) when self#is_immediate n ->
+method select_condition c =
+  let mk = mkdbg c.dbg in
+  match c.exp with
+    Cop(Ccmpi cmp, [arg1; {exp=Cconst_int n}]) when self#is_immediate n ->
       (Iinttest_imm(Isigned cmp, n), arg1)
-  | Cop(Ccmpi cmp, [Cconst_int n; arg2]) when self#is_immediate n ->
+  | Cop(Ccmpi cmp, [{exp=Cconst_int n}; arg2]) when self#is_immediate n ->
       (Iinttest_imm(Isigned(swap_comparison cmp), n), arg2)
-  | Cop(Ccmpi cmp, [arg1; Cconst_pointer n]) when self#is_immediate n ->
+  | Cop(Ccmpi cmp, [arg1; {exp=Cconst_pointer n}]) when self#is_immediate n ->
       (Iinttest_imm(Isigned cmp, n), arg1)
-  | Cop(Ccmpi cmp, [Cconst_pointer n; arg2]) when self#is_immediate n ->
+  | Cop(Ccmpi cmp, [{exp=Cconst_pointer n}; arg2]) when self#is_immediate n ->
       (Iinttest_imm(Isigned(swap_comparison cmp), n), arg2)
   | Cop(Ccmpi cmp, args) ->
-      (Iinttest(Isigned cmp), Ctuple args)
-  | Cop(Ccmpa cmp, [arg1; Cconst_pointer n]) when self#is_immediate n ->
+      (Iinttest(Isigned cmp), mk(Ctuple args))
+  | Cop(Ccmpa cmp, [arg1; {exp=Cconst_pointer n}]) when self#is_immediate n ->
       (Iinttest_imm(Iunsigned cmp, n), arg1)
-  | Cop(Ccmpa cmp, [arg1; Cconst_int n]) when self#is_immediate n ->
+  | Cop(Ccmpa cmp, [arg1; {exp=Cconst_int n}]) when self#is_immediate n ->
       (Iinttest_imm(Iunsigned cmp, n), arg1)
-  | Cop(Ccmpa cmp, [Cconst_pointer n; arg2]) when self#is_immediate n ->
+  | Cop(Ccmpa cmp, [{exp=Cconst_pointer n}; arg2]) when self#is_immediate n ->
       (Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2)
-  | Cop(Ccmpa cmp, [Cconst_int n; arg2]) when self#is_immediate n ->
+  | Cop(Ccmpa cmp, [{exp=Cconst_int n}; arg2]) when self#is_immediate n ->
       (Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2)
   | Cop(Ccmpa cmp, args) ->
-      (Iinttest(Iunsigned cmp), Ctuple args)
+      (Iinttest(Iunsigned cmp), mk(Ctuple args))
   | Cop(Ccmpf cmp, args) ->
-      (Ifloattest(cmp, false), Ctuple args)
-  | Cop(Cand, [arg; Cconst_int 1]) ->
+      (Ifloattest(cmp, false), mk(Ctuple args))
+  | Cop(Cand, [arg; {exp=Cconst_int 1}]) ->
       (Ioddtest, arg)
-  | arg ->
-      (Itruetest, arg)
+  | _ ->
+      (Itruetest, c)
 
 (* Return an array of fresh registers of the given type.
    Normally implemented as Reg.createv, but some
@@ -346,12 +342,9 @@ method regs_for tys = Reg.createv tys
 
 val mutable instr_seq = dummy_instr
 
-method insert_debug desc dbg arg res =
+method insert desc dbg arg res =
   instr_seq <- instr_cons_debug desc arg res dbg instr_seq
 
-method insert desc arg res =
-  instr_seq <- instr_cons desc arg res instr_seq
-
 method extract =
   let rec extract res i =
     if i == dummy_instr
@@ -361,60 +354,58 @@ method extract =
 
 (* Insert a sequence of moves from one pseudoreg set to another. *)
 
-method insert_move src dst =
+method insert_move dbg src dst =
   if src.stamp <> dst.stamp then
-    self#insert (Iop Imove) [|src|] [|dst|]
+    self#insert (Iop Imove) dbg [|src|] [|dst|]
 
-method insert_moves src dst =
+method insert_moves dbg src dst =
   for i = 0 to Array.length src - 1 do
-    self#insert_move src.(i) dst.(i)
+    self#insert_move dbg src.(i) dst.(i)
   done
 
 (* Insert moves and stack offsets for function arguments and results *)
 
-method insert_move_args arg loc stacksize =
-  if stacksize <> 0 then self#insert (Iop(Istackoffset stacksize)) [||] [||];
-  self#insert_moves arg loc
+method insert_move_args dbg arg loc stacksize =
+  if stacksize <> 0 then self#insert (Iop(Istackoffset stacksize)) dbg [||] [||];
+  self#insert_moves dbg arg loc
 
-method insert_move_results loc res stacksize =
-  if stacksize <> 0 then self#insert(Iop(Istackoffset(-stacksize))) [||] [||];
-  self#insert_moves loc res
+method insert_move_results dbg loc res stacksize =
+  if stacksize <> 0 then self#insert (Iop(Istackoffset(-stacksize))) dbg [||] [||];
+  self#insert_moves dbg loc res
 
 (* Add an Iop opcode. Can be overridden by processor description
    to insert moves before and after the operation, i.e. for two-address
    instructions, or instructions using dedicated registers. *)
 
-method insert_op_debug op dbg rs rd =
-  self#insert_debug (Iop op) dbg rs rd;
-  rd
-
-method insert_op op rs rd =
-  self#insert (Iop op) rs rd;
+method insert_op op dbg rs rd =
+  self#insert (Iop op) dbg rs rd;
   rd
 
 (* Add the instructions for the given expression
    at the end of the self sequence *)
 
 method emit_expr env exp =
-  match exp with
+  let dbg = exp.dbg in
+  let mk = mkdbg exp.dbg in
+  match exp.exp with
     Cconst_int n ->
       let r = self#regs_for typ_int in
-      Some(self#insert_op (Iconst_int(Nativeint.of_int n)) [||] r)
+      Some(self#insert_op (Iconst_int(Nativeint.of_int n)) dbg [||] r)
   | Cconst_natint n ->
       let r = self#regs_for typ_int in
-      Some(self#insert_op (Iconst_int n) [||] r)
+      Some(self#insert_op (Iconst_int n) dbg [||] r)
   | Cconst_float n ->
       let r = self#regs_for typ_float in
-      Some(self#insert_op (Iconst_float n) [||] r)
+      Some(self#insert_op (Iconst_float n) dbg [||] r)
   | Cconst_symbol n ->
       let r = self#regs_for typ_addr in
-      Some(self#insert_op (Iconst_symbol n) [||] r)
+      Some(self#insert_op (Iconst_symbol n) dbg [||] r)
   | Cconst_pointer n ->
       let r = self#regs_for typ_addr in
-      Some(self#insert_op (Iconst_int(Nativeint.of_int n)) [||] r)
+      Some(self#insert_op (Iconst_int(Nativeint.of_int n)) dbg [||] r)
   | Cconst_natpointer n ->
       let r = self#regs_for typ_addr in
-      Some(self#insert_op (Iconst_int n) [||] r)
+      Some(self#insert_op (Iconst_int n) dbg [||] r)
   | Cvar v ->
       begin try
         Some(Tbl.find v env)
@@ -434,7 +425,7 @@ method emit_expr env exp =
           fatal_error ("Selection.emit_expr: unbound var " ^ Ident.name v) in
       begin match self#emit_expr env e1 with
         None -> None
-      | Some r1 -> self#insert_moves r1 rv; Some [||]
+      | Some r1 -> self#insert_moves dbg r1 rv; Some [||]
       end
   | Ctuple [] ->
       Some [||]
@@ -444,24 +435,23 @@ method emit_expr env exp =
       | Some(simple_list, ext_env) ->
           Some(self#emit_tuple ext_env simple_list)
       end
-  | Cop(Craise dbg, [arg]) ->
+  | Cop(Craise, [arg]) ->
       begin match self#emit_expr env arg with
         None -> None
       | Some r1 ->
           let rd = [|Proc.loc_exn_bucket|] in
-          self#insert (Iop Imove) r1 rd;
-          self#insert_debug Iraise dbg rd [||];
+          self#insert (Iop Imove) dbg r1 rd;
+          self#insert Iraise dbg rd [||];
           None
       end
   | Cop(Ccmpf comp, args) ->
-      self#emit_expr env (Cifthenelse(exp, Cconst_int 1, Cconst_int 0))
+      self#emit_expr env (mk(Cifthenelse(exp, mk(Cconst_int 1), mk(Cconst_int 0))))
   | Cop(op, args) ->
       begin match self#emit_parts_list env args with
         None -> None
       | Some(simple_args, env) ->
           let ty = oper_result_type op in
           let (new_op, new_args) = self#select_operation op simple_args in
-          let dbg = debuginfo_op op in
           match new_op with
             Icall_ind ->
               Proc.contains_calls := true;
@@ -470,10 +460,10 @@ method emit_expr env exp =
               let rd = self#regs_for ty in
               let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in
               let loc_res = Proc.loc_results rd in
-              self#insert_move_args rarg loc_arg stack_ofs;
-              self#insert_debug (Iop Icall_ind) dbg
+              self#insert_move_args dbg rarg loc_arg stack_ofs;
+              self#insert (Iop Icall_ind) dbg
                           (Array.append [|r1.(0)|] loc_arg) loc_res;
-              self#insert_move_results loc_res rd stack_ofs;
+              self#insert_move_results dbg loc_res rd stack_ofs;
               Some rd
           | Icall_imm lbl ->
               Proc.contains_calls := true;
@@ -481,9 +471,9 @@ method emit_expr env exp =
               let rd = self#regs_for ty in
               let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in
               let loc_res = Proc.loc_results rd in
-              self#insert_move_args r1 loc_arg stack_ofs;
-              self#insert_debug (Iop(Icall_imm lbl)) dbg loc_arg loc_res;
-              self#insert_move_results loc_res rd stack_ofs;
+              self#insert_move_args dbg r1 loc_arg stack_ofs;
+              self#insert (Iop(Icall_imm lbl)) dbg loc_arg loc_res;
+              self#insert_move_results dbg loc_res rd stack_ofs;
               Some rd
           | Iextcall(lbl, alloc) ->
               Proc.contains_calls := true;
@@ -491,21 +481,21 @@ method emit_expr env exp =
                 self#emit_extcall_args env new_args in
               let rd = self#regs_for ty in
               let loc_res = Proc.loc_external_results rd in
-              self#insert_debug (Iop(Iextcall(lbl, alloc))) dbg
+              self#insert (Iop(Iextcall(lbl, alloc))) dbg
                              loc_arg loc_res;
-              self#insert_move_results loc_res rd stack_ofs;
+              self#insert_move_results dbg loc_res rd stack_ofs;
               Some rd
           | Ialloc _ ->
               Proc.contains_calls := true;
               let rd = self#regs_for typ_addr in
-              let size = size_expr env (Ctuple new_args) in
-              self#insert (Iop(Ialloc size)) [||] rd;
+              let size = size_expr env (mk(Ctuple new_args)) in
+              self#insert (Iop(Ialloc size)) dbg [||] rd;
               self#emit_stores env new_args rd;
               Some rd
           | op ->
               let r1 = self#emit_tuple env new_args in
               let rd = self#regs_for ty in
-              Some (self#insert_op_debug op dbg r1 rd)
+              Some (self#insert_op op dbg r1 rd)
       end
   | Csequence(e1, e2) ->
       begin match self#emit_expr env e1 with
@@ -521,7 +511,7 @@ method emit_expr env exp =
           let (relse, selse) = self#emit_sequence env eelse in
           let r = join rif sif relse selse in
           self#insert (Iifthenelse(cond, sif#extract, selse#extract))
-                      rarg [||];
+                      dbg rarg [||];
           r
       end
   | Cswitch(esel, index, ecases) ->
@@ -532,12 +522,12 @@ method emit_expr env exp =
           let r = join_array rscases in
           self#insert (Iswitch(index,
                                Array.map (fun (r, s) -> s#extract) rscases))
-                      rsel [||];
+                      dbg rsel [||];
           r
       end
   | Cloop(ebody) ->
       let (rarg, sbody) = self#emit_sequence env ebody in
-      self#insert (Iloop(sbody#extract)) [||] [||];
+      self#insert (Iloop(sbody#extract)) dbg [||] [||];
       Some [||]
   | Ccatch(nfail, ids, e1, e2) ->
       let rs =
@@ -554,7 +544,7 @@ method emit_expr env exp =
         env (List.combine ids rs) in
       let (r2, s2) = self#emit_sequence new_env e2 in
       let r = join r1 s1 r2 s2 in
-      self#insert (Icatch(nfail, s1#extract, s2#extract)) [||] [||];
+      self#insert (Icatch(nfail, s1#extract, s2#extract)) dbg [||] [||];
       r
   | Cexit (nfail,args) ->
       begin match self#emit_parts_list env args with
@@ -566,8 +556,8 @@ method emit_expr env exp =
             with Not_found ->
               Misc.fatal_error
                 ("Selectgen.emit_expr, on exit("^string_of_int nfail^")") in
-          self#insert_moves src dest ;
-          self#insert (Iexit nfail) [||] [||];
+          self#insert_moves dbg src dest ;
+          self#insert (Iexit nfail) dbg [||] [||];
           None
       end
   | Ctrywith(e1, v, e2) ->
@@ -578,11 +568,11 @@ method emit_expr env exp =
       let r = join r1 s1 r2 s2 in
       self#insert
         (Itrywith(s1#extract,
-                  instr_cons (Iop Imove) [|Proc.loc_exn_bucket|] rv
-                             (s2#extract)))
-        [||] [||];
+                  instr_cons_debug (Iop Imove) [|Proc.loc_exn_bucket|] rv
+                             dbg (s2#extract)))
+        dbg [||] [||];
       r
-
+    
 method private emit_sequence env exp =
   let s = {< instr_seq = dummy_instr >} in
   let r = s#emit_expr env exp in
@@ -595,11 +585,12 @@ method private bind_let env v r1 =
   end else begin
     let rv = Reg.createv_like r1 in
     name_regs v rv;
-    self#insert_moves r1 rv;
+    self#insert_moves Debuginfo.none r1 rv;
     Tbl.add v rv env
   end
 
 method private emit_parts env exp =
+  let mk = mkdbg exp.dbg in
   if self#is_simple_expr exp then
     Some (exp, env)
   else begin
@@ -607,18 +598,18 @@ method private emit_parts env exp =
       None -> None
     | Some r ->
         if Array.length r = 0 then
-          Some (Ctuple [], env)
+          Some (mk(Ctuple []), env)
         else begin
           (* The normal case *)
           let id = Ident.create "bind" in
           if all_regs_anonymous r then
             (* r is an anonymous, unshared register; use it directly *)
-            Some (Cvar id, Tbl.add id r env)
+            Some (mk(Cvar id), Tbl.add id r env)
           else begin
             (* Introduce a fresh temp to hold the result *)
             let tmp = Reg.createv_like r in
-            self#insert_moves r tmp;
-            Some (Cvar id, Tbl.add id tmp env)
+            self#insert_moves exp.dbg r tmp;
+            Some (mk(Cvar id), Tbl.add id tmp env)
           end
         end
   end
@@ -650,7 +641,7 @@ method private emit_tuple env exp_list =
 method emit_extcall_args env args =
   let r1 = self#emit_tuple env args in
   let (loc_arg, stack_ofs as arg_stack) = Proc.loc_external_arguments r1 in
-  self#insert_move_args r1 loc_arg stack_ofs;
+  self#insert_move_args Debuginfo.none r1 loc_arg stack_ofs;
   arg_stack
 
 method emit_stores env data regs_addr =
@@ -662,17 +653,18 @@ method emit_stores env data regs_addr =
       match self#emit_expr env arg with
         None -> assert false
       | Some regs ->
+          let dbg = arg.dbg in
           match op with
             Istore(_, _) ->
               for i = 0 to Array.length regs - 1 do
                 let r = regs.(i) in
                 let kind = if r.typ = Float then Double_u else Word in
-                self#insert (Iop(Istore(kind, !a)))
+                self#insert (Iop(Istore(kind, !a))) dbg
                             (Array.append [|r|] regs_addr) [||];
                 a := Arch.offset_addressing !a (size_component r.typ)
               done
           | _ ->
-              self#insert (Iop op) (Array.append regs regs_addr) [||];
+              self#insert (Iop op) dbg (Array.append regs regs_addr) [||];
               a := Arch.offset_addressing !a (size_expr env e))
     data
 
@@ -683,17 +675,19 @@ method private emit_return env exp =
     None -> ()
   | Some r ->
       let loc = Proc.loc_results r in
-      self#insert_moves r loc;
-      self#insert Ireturn loc [||]
+      let dbg = exp.dbg in
+      self#insert_moves dbg r loc;
+      self#insert Ireturn dbg loc [||]
 
 method emit_tail env exp =
-  match exp with
+  let dbg = exp.dbg in
+  match exp.exp with
     Clet(v, e1, e2) ->
       begin match self#emit_expr env e1 with
         None -> ()
       | Some r1 -> self#emit_tail (self#bind_let env v r1) e2
       end
-  | Cop(Capply(ty, dbg) as op, args) ->
+  | Cop(Capply ty as op, args) ->
       begin match self#emit_parts_list env args with
         None -> ()
       | Some(simple_args, env) ->
@@ -704,37 +698,37 @@ method emit_tail env exp =
               let rarg = Array.sub r1 1 (Array.length r1 - 1) in
               let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in
               if stack_ofs = 0 then begin
-                self#insert_moves rarg loc_arg;
-                self#insert (Iop Itailcall_ind)
+                self#insert_moves dbg rarg loc_arg;
+                self#insert (Iop Itailcall_ind) dbg
                             (Array.append [|r1.(0)|] loc_arg) [||]
               end else begin
                 Proc.contains_calls := true;
                 let rd = self#regs_for ty in
                 let loc_res = Proc.loc_results rd in
-                self#insert_move_args rarg loc_arg stack_ofs;
-                self#insert_debug (Iop Icall_ind) dbg
+                self#insert_move_args dbg rarg loc_arg stack_ofs;
+                self#insert (Iop Icall_ind) dbg
                             (Array.append [|r1.(0)|] loc_arg) loc_res;
-                self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||];
-                self#insert Ireturn loc_res [||]
+                self#insert (Iop(Istackoffset(-stack_ofs))) dbg [||] [||];
+                self#insert Ireturn dbg loc_res [||]
               end
           | Icall_imm lbl ->
               let r1 = self#emit_tuple env new_args in
               let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in
               if stack_ofs = 0 then begin
-                self#insert_moves r1 loc_arg;
-                self#insert (Iop(Itailcall_imm lbl)) loc_arg [||]
+                self#insert_moves dbg r1 loc_arg;
+                self#insert (Iop(Itailcall_imm lbl)) dbg loc_arg [||]
               end else if lbl = !current_function_name then begin
                 let loc_arg' = Proc.loc_parameters r1 in
-                self#insert_moves r1 loc_arg';
-                self#insert (Iop(Itailcall_imm lbl)) loc_arg' [||]
+                self#insert_moves dbg r1 loc_arg';
+                self#insert (Iop(Itailcall_imm lbl)) dbg loc_arg' [||]
               end else begin
                 Proc.contains_calls := true;
                 let rd = self#regs_for ty in
                 let loc_res = Proc.loc_results rd in
-                self#insert_move_args r1 loc_arg stack_ofs;
-                self#insert_debug (Iop(Icall_imm lbl)) dbg loc_arg loc_res;
-                self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||];
-                self#insert Ireturn loc_res [||]
+                self#insert_move_args dbg r1 loc_arg stack_ofs;
+                self#insert (Iop(Icall_imm lbl)) dbg loc_arg loc_res;
+                self#insert (Iop(Istackoffset(-stack_ofs))) dbg [||] [||];
+                self#insert Ireturn dbg loc_res [||]
               end
           | _ -> fatal_error "Selection.emit_tail"
       end
@@ -750,7 +744,7 @@ method emit_tail env exp =
       | Some rarg ->
           self#insert (Iifthenelse(cond, self#emit_tail_sequence env eif,
                                          self#emit_tail_sequence env eelse))
-                      rarg [||]
+                      dbg rarg [||]
       end
   | Cswitch(esel, index, ecases) ->
       begin match self#emit_expr env esel with
@@ -758,7 +752,7 @@ method emit_tail env exp =
       | Some rsel ->
           self#insert
             (Iswitch(index, Array.map (self#emit_tail_sequence env) ecases))
-            rsel [||]
+            dbg rsel [||]
       end
   | Ccatch(nfail, ids, e1, e2) ->
        let rs =
@@ -776,7 +770,7 @@ method emit_tail env exp =
         (fun env (id,r) -> Tbl.add id r env)
         env (List.combine ids rs) in
       let s2 = self#emit_tail_sequence new_env e2 in
-      self#insert (Icatch(nfail, s1, s2)) [||] [||]
+      self#insert (Icatch(nfail, s1, s2)) dbg [||] [||]
   | Ctrywith(e1, v, e2) ->
       Proc.contains_calls := true;
       let (opt_r1, s1) = self#emit_sequence env e1 in
@@ -784,14 +778,14 @@ method emit_tail env exp =
       let s2 = self#emit_tail_sequence (Tbl.add v rv env) e2 in
       self#insert
         (Itrywith(s1#extract,
-                  instr_cons (Iop Imove) [|Proc.loc_exn_bucket|] rv s2))
-        [||] [||];
+                  instr_cons_debug (Iop Imove) [|Proc.loc_exn_bucket|] rv dbg s2))
+        dbg [||] [||];
       begin match opt_r1 with
         None -> ()
       | Some r1 ->
           let loc = Proc.loc_results r1 in
-          self#insert_moves r1 loc;
-          self#insert Ireturn loc [||]
+          self#insert_moves dbg r1 loc;
+          self#insert Ireturn dbg loc [||]
       end
   | _ ->
       self#emit_return env exp
@@ -816,7 +810,7 @@ method emit_fundecl f =
     List.fold_right2
       (fun (id, ty) r env -> Tbl.add id r env)
       f.Cmm.fun_args rargs Tbl.empty in
-  self#insert_moves loc_arg rarg;
+  self#insert_moves Debuginfo.none loc_arg rarg;
   self#emit_tail env f.Cmm.fun_body;
   { fun_name = f.Cmm.fun_name;
     fun_args = loc_arg;
@@ -827,15 +821,15 @@ method emit_fundecl f =
 end
 
 (* Tail call criterion (estimated).  Assumes:
-- all arguments are of type "int" (always the case for Caml function calls)
-- one extra argument representing the closure environment (conservative).
+ - all arguments are of type "int" (always the case for Caml function calls)
+ - one extra argument representing the closure environment (conservative).
 *)
-
+ 
 let is_tail_call nargs =
   assert (Reg.dummy.typ = Int);
   let args = Array.make (nargs + 1) Reg.dummy in
   let (loc_arg, stack_ofs) = Proc.loc_arguments args in
   stack_ofs = 0
-
+ 
 let _ =
   Simplif.is_tail_native_heuristic := is_tail_call
diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli
index 7c30f9f..a896ce9 100644
--- a/asmcomp/selectgen.mli
+++ b/asmcomp/selectgen.mli
@@ -45,10 +45,6 @@ class virtual selector_generic : object
        Can be overridden if float values are stored as pairs of
        integer registers. *)
   method insert_op :
-    Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array
-    (* Can be overridden to deal with 2-address instructions
-       or instructions with hardwired input/output registers *)
-  method insert_op_debug :
     Mach.operation -> Debuginfo.t -> Reg.t array -> Reg.t array -> Reg.t array
     (* Can be overridden to deal with 2-address instructions
        or instructions with hardwired input/output registers *)
@@ -67,13 +63,12 @@ class virtual selector_generic : object
      declared "private" in the current implementation because they
      are not always applied to "self", but ideally they should be private. *)
   method extract : Mach.instruction
-  method insert : Mach.instruction_desc -> Reg.t array -> Reg.t array -> unit
-  method insert_debug : Mach.instruction_desc -> Debuginfo.t ->
+  method insert : Mach.instruction_desc -> Debuginfo.t ->
                                         Reg.t array -> Reg.t array -> unit
-  method insert_move : Reg.t -> Reg.t -> unit
-  method insert_move_args : Reg.t array -> Reg.t array -> int -> unit
-  method insert_move_results : Reg.t array -> Reg.t array -> int -> unit
-  method insert_moves : Reg.t array -> Reg.t array -> unit
+  method insert_move : Debuginfo.t -> Reg.t -> Reg.t -> unit
+  method insert_move_args : Debuginfo.t -> Reg.t array -> Reg.t array -> int -> unit
+  method insert_move_results : Debuginfo.t -> Reg.t array -> Reg.t array -> int -> unit
+  method insert_moves : Debuginfo.t -> Reg.t array -> Reg.t array -> unit
   method emit_expr :
     (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> Reg.t array option
   method emit_tail : (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> unit
-- 
1.7.5.4