Passage au truc d'Appel pour les fermetures de fonctions mutuellement

recursives.
Changement du layout de try ... with ...
Correction de bugs dans la generation des descripteurs de frames.


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

17 files changed, 330 insertions, 252 deletions

diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml
index 1ccc7005f..3e7e59252 100644
--- a/asmcomp/asmgen.ml
+++ b/asmcomp/asmgen.ml
@@ -64,7 +64,9 @@ let compile_implementation prefixname lam =
     Emit.end_assembly();
     close_out oc
   with x ->
-    close_out oc; (*remove_file asmfile;*) raise x
+    close_out oc;
+    if !assembler_only then () else remove_file asmfile;
+    raise x
   end;
   if !assembler_only then () else begin
     if Proc.assemble_file asmfile (prefixname ^ ".o") <> 0
diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml
index aad744d12..5938c035d 100644
--- a/asmcomp/clambda.ml
+++ b/asmcomp/clambda.ml
@@ -11,7 +11,9 @@ type ulambda =
   | Uconst of structured_constant
   | Udirect_apply of function_label * ulambda list
   | Ugeneric_apply of ulambda * ulambda list
-  | Uclosure of function_label * int * Ident.t list * ulambda * ulambda list
+  | Uclosure of (function_label * int * Ident.t list * ulambda) 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
diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli
index aad744d12..5938c035d 100644
--- a/asmcomp/clambda.mli
+++ b/asmcomp/clambda.mli
@@ -11,7 +11,9 @@ type ulambda =
   | Uconst of structured_constant
   | Udirect_apply of function_label * ulambda list
   | Ugeneric_apply of ulambda * ulambda list
-  | Uclosure of function_label * int * Ident.t list * ulambda * ulambda list
+  | Uclosure of (function_label * int * Ident.t list * ulambda) 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
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index 6183c351c..a103c22e2 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -25,19 +25,6 @@ let rec build_closure_env env_param pos = function
       Tbl.add id (Uprim(Pfield pos, [Uvar env_param])) 
               (build_closure_env env_param (pos+1) rem)
 
-(* Auxiliaries for compiling recursive definitions *)
-
-type fun_analysis =
-  { fa_desc: function_description;
-    fa_params: Ident.t list;
-    fa_body: lambda;
-    fa_cenv: (Ident.t, ulambda) Tbl.t;
-    fa_clos: ulambda list }
-
-type rec_approximation =
-    Rec_function of fun_analysis
-  | Rec_other of lambda
-
 (* Uncurry an expression and explicitate closures.
    Also return the approximation of the expression.
    The approximation environment [fenv] maps idents to approximations.
@@ -45,14 +32,19 @@ type rec_approximation =
    The closure environment [cenv] maps idents to [ulambda] terms.
    It is used to substitute environment accesses for free identifiers. *)
 
+let close_var cenv id =
+  try Tbl.find id cenv with Not_found -> Uvar id
+
+let approx_var fenv id =
+  try Tbl.find id fenv with Not_found -> Value_unknown 
+
 let rec close fenv cenv = function
     Lvar id ->
-      (begin try Tbl.find id cenv with Not_found -> Uvar id end,
-       begin try Tbl.find id fenv with Not_found -> Value_unknown end)
+      (close_var cenv id, approx_var fenv id)
   | Lconst cst ->
       (Uconst cst, Value_unknown)
   | Lfunction(param, body) as funct ->
-      close_function fenv cenv (Ident.new "fun") funct
+      close_one_function fenv cenv (Ident.new "fun") funct
   | Lapply(funct, args) ->
       let nargs = List.length args in
       begin match close fenv cenv funct with
@@ -76,45 +68,40 @@ let rec close fenv cenv = function
           (Ugeneric_apply(ufunct, close_list fenv cenv args), Value_unknown)
       end
   | Llet(id, lam, body) ->
-      let (ulam, alam) = close_named  fenv cenv id lam in
+      let (ulam, alam) = close_named fenv cenv id lam in
       let (ubody, abody) = close (Tbl.add id alam fenv) cenv body in
       (Ulet(id, ulam, ubody), abody)
-  | Lletrec([id, (Lfunction(_, _) as funct)], body) ->
-      let funapp = close_analyze_function_rec1 fenv cenv id funct in
-      let (ufunct, approx) =
-        close_build_function
-          (Tbl.add id (Value_closure(funapp.fa_desc, Value_unknown)) fenv)
-          funapp in
-      let (ubody, approx) = close (Tbl.add id approx fenv) cenv body in
-      (Ulet(id, ufunct, ubody), approx)
-  | Lletrec(decls, body) ->
-      let rec make_rec_fenv = function
-        [] -> (fenv, [])
-      | (id, lam) :: rem ->
-          let (new_fenv, precomp) = make_rec_fenv rem in
-          match lam with
-            Lfunction(param, body) ->
-              let funapp = close_analyze_function fenv cenv id lam in
-              (Tbl.add id (Value_closure(funapp.fa_desc, Value_unknown))
-                       new_fenv,
-               (id, Rec_function funapp) :: precomp)
-          | _ ->
-              (new_fenv, (id, Rec_other lam) :: precomp) in
-      let (rec_fenv, precomp) = make_rec_fenv decls in
-      let rec close_decls = function
-        [] -> (fenv, [])
-      | (id, pre) :: rem ->
-          let (new_fenv, urem) = close_decls rem in
-          match pre with
-            Rec_function funapp ->
-              let (ulam, approx) = close_build_function rec_fenv funapp in
-              (Tbl.add id approx new_fenv, (id, ulam) :: urem)
-          | Rec_other lam ->
-              let (ulam, approx) = close rec_fenv cenv lam in
-              (Tbl.add id approx new_fenv, (id, ulam) :: urem) in
-      let (body_fenv, udecls) = close_decls precomp in
-      let (ubody, approx) = close body_fenv cenv body in
-      (Uletrec(udecls, ubody), approx)
+  | Lletrec(defs, body) ->
+      if List.for_all
+           (function (id, Lfunction(_, _)) -> true | _ -> false)
+           defs
+      then begin
+        (* Simple case: only function definitions *)
+        let (clos, infos) = close_functions fenv cenv defs in
+        let clos_ident = Ident.new "clos" in
+        let fenv_body =
+          List.fold_right
+            (fun (id, pos, approx) fenv -> Tbl.add id approx fenv)
+            infos fenv in
+        let cenv_body =
+          List.fold_right
+            (fun (id, pos, approx) cenv ->
+              Tbl.add id (Uoffset(Uvar clos_ident, pos)) cenv)
+            infos cenv in
+        let (ubody, approx) = close fenv_body cenv_body body in
+        (Ulet(clos_ident, clos, ubody), approx)
+      end else begin
+        (* General case: recursive definition of values *)
+        let rec clos_defs = function
+          [] -> ([], fenv)
+        | (id, lam) :: rem ->
+            let (udefs, fenv_body) = clos_defs rem in
+            let (ulam, approx) = close fenv cenv lam in
+            ((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)
+      end
   | Lprim(Pgetglobal id, []) ->
       (Uprim(Pgetglobal id, []), Compilenv.global_approx id)
   | Lprim(Psetglobal id, [lam]) ->
@@ -177,61 +164,71 @@ and close_list fenv cenv = function
 
 and close_named fenv cenv id = function
     Lfunction(param, body) as funct ->
-      close_function fenv cenv id funct
+      close_one_function fenv cenv id funct
   | lam ->
       close fenv cenv lam
 
-(* Build a function closure with the given name *)
-
-and close_function fenv cenv id funct =
-  close_build_function fenv (close_analyze_function fenv cenv id funct)
-  
-(* Return preliminary information for a function closure *)
-
-and close_analyze_function fenv cenv id funct =
-  let fv = IdentSet.elements(free_variables funct) in
-  let label = Compilenv.current_unit_name() ^ "_" ^ Ident.unique_name id in
-  let (params, body) = uncurry_fun funct in
-  let arity = List.length params in
-  let env_param = Ident.new "env" in
-  let cenv_body =
-    build_closure_env env_param (if arity > 1 then 3 else 2) fv in
-  {fa_desc = {fun_label = label; fun_arity = arity; fun_closed = (fv=[])};
-   fa_params = params @ [env_param];
-   fa_body = body;
-   fa_cenv = cenv_body;
-   fa_clos = close_list fenv cenv (List.map (fun id -> Lvar id) fv)}
-
-(* Same, but for a simply recursive function. In this case, the closure for
-   the function itself is in its environment parameter. *)
+(* Build a shared closure for a set of mutually recursive functions *)
 
-and close_analyze_function_rec1 fenv cenv id funct =
-  let fv = IdentSet.elements(IdentSet.remove id (free_variables funct)) in
-  let label = Compilenv.current_unit_name() ^ "_" ^ Ident.unique_name id in
-  let (params, body) = uncurry_fun funct in
-  let arity = List.length params in
-  let env_param = Ident.new "env" in
-  let cenv_body =
-    Tbl.add id (Uvar env_param)
-      (build_closure_env env_param (if arity > 1 then 3 else 2) fv) in
-  (* Even if fv = [], env may be used inside to refer to the functional
-     value of the function. Not detected here. *)
-  {fa_desc = {fun_label = label; fun_arity = arity; fun_closed = false};
-   fa_params = params @ [env_param];
-   fa_body = body;
-   fa_cenv = cenv_body;
-   fa_clos = close_list fenv cenv (List.map (fun id -> Lvar id) fv)}
+and close_functions fenv cenv fun_defs =
+  (* Determine the free variables of the functions *)
+  let fv =
+    IdentSet.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in
+  (* Uncurry the definitions and build their fundesc *)
+  let uncurried_defs =
+    List.map
+      (fun (id, def) ->
+        let label =
+          Compilenv.current_unit_name() ^ "_" ^ Ident.unique_name id in
+        let (params, body) = uncurry_fun def in
+        let fundesc =
+          {fun_label = Compilenv.current_unit_name() ^ "_" ^
+                       Ident.unique_name id;
+           fun_arity = List.length params;
+           fun_closed = IdentSet.is_empty(free_variables def)} in
+        (id, params, body, fundesc))
+      fun_defs in
+  (* Build an approximate fenv for compiling the functions *)
+  let fenv_rec =
+    List.fold_right
+      (fun (id, params, body, fundesc) fenv ->
+        Tbl.add id (Value_closure(fundesc, Value_unknown)) fenv)
+      uncurried_defs fenv in
+  (* Determine the offsets of each function's closure in the shared block *)
+  let env_pos = ref (-1) in
+  let clos_offsets =
+    List.map
+      (fun (id, params, body, fundesc) ->
+        let pos = !env_pos + 1 in
+        env_pos := !env_pos + 1 + (if fundesc.fun_arity > 1 then 3 else 2);
+        pos)
+      uncurried_defs in
+  let fv_pos = !env_pos in
+  (* Translate each function definition *)
+  let clos_fundef (id, params, body, fundesc) env_pos =
+    let env_param = Ident.new "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)
+        uncurried_defs clos_offsets cenv_fv in
+    let (ubody, approx) = close fenv_rec cenv_body body in
+    ((fundesc.fun_label, fundesc.fun_arity, params @ [env_param], ubody),
+     (id, env_pos, Value_closure(fundesc, approx))) in
+  (* Translate all function definitions. Return the Uclosure node and
+     the list of all identifiers defined, with offsets and approximations. *)
+  let (clos, infos) =
+    List.split (List.map2 clos_fundef uncurried_defs clos_offsets) in
+  (Uclosure(clos, List.map (close_var cenv) fv), infos)
 
-(* Actually build the function closure based on infos returned by
-   [close_analyze_function] *)
+(* Same, for one function *)
 
-and close_build_function fenv funapp =
-  (* No need to add [params] to [fenv] since their approximations are
-     unknown anyway *)
-  let (ubody, approx) = close fenv funapp.fa_cenv funapp.fa_body in
-  (Uclosure(funapp.fa_desc.fun_label, funapp.fa_desc.fun_arity,
-            funapp.fa_params, ubody, funapp.fa_clos),
-   Value_closure(funapp.fa_desc, approx))
+and close_one_function fenv cenv id funct =
+  match close_functions fenv cenv [id, funct] with
+      (clos, (id, pos, approx) :: _) -> (clos, approx)
+    | _ -> fatal_error "Closure.close_one_function"
 
 (* Close a switch, preserving sharing between cases. *)
 
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index d3d159e65..07ff5d3b4 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -7,12 +7,25 @@ open Lambda
 open Clambda
 open Cmm
 
-(* Block headers *)
-
-let block_header tag sz = (sz lsl 10) + tag
-let closure_header sz = block_header 251 sz
-let float_header = block_header 254 (size_float / size_addr)
-let string_header len = block_header 253 ((len + size_addr) / size_addr)
+(* Block headers. Meaning of the tag field:
+       0xFF: infix header
+       0xFE: finalized
+       0xFD: abstract
+       0xFC: string
+       0xFB: float
+       0xFA: closure
+       0 - 0xF9: regular blocks *)
+
+let block_header tag sz = (sz lsl 11) + tag
+let closure_header sz = block_header 0xFA sz
+let infix_header ofs = block_header 0xFF ofs
+let float_header = block_header 0xFB (size_float / size_addr)
+let string_header len = block_header 0xFC ((len + size_addr) / size_addr)
+
+let modified = 1 lsl 10
+let alloc_block_header tag sz = Cconst_int((block_header tag sz) lor modified)
+let alloc_closure_header sz = Cconst_int((closure_header sz) lor modified)
+let alloc_infix_header ofs = Cconst_int(infix_header ofs)
 
 (* Integers *)
 
@@ -153,11 +166,19 @@ let array_indexing ptr ofs =
       Cop(Cadda, [ptr; add_const (lsl_const ofs (log2_size_addr - 1))
                                  ((-1) lsl (log2_size_addr - 1))])
 
-(* To compile "let rec" *)
+(* To compile "let rec" over values *)
+
+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))
+    fundecls;
+  !sz
 
 let rec expr_size = function
-    Uclosure(lbl, arity, params, body, clos_vars) ->
-      (if arity = 1 then 2 else 3) + List.length clos_vars
+    Uclosure(fundecls, clos_vars) ->
+      fundecls_size fundecls + List.length clos_vars
   | Uprim(Pmakeblock tag, args) ->
       List.length args
   | Ulet(id, exp, body) ->
@@ -166,13 +187,9 @@ let rec expr_size = function
       fatal_error "Cmmgen.expr_size"
 
 let dummy_block size =
-  if size > 4 then
-    Cop(Cextcall("alloc_dummy", typ_addr), [Cconst_int size])
-  else begin
-    let rec init_val i =
-      if i >= size then [] else Cconst_int 0 :: init_val(i+1) in
-    Cop(Calloc, Cconst_int(block_header 0 size) :: init_val 0)
-  end
+  let rec init_val i =
+    if i >= size then [] else Cconst_int 0 :: init_val(i+1) in
+  Cop(Calloc, alloc_block_header 0 size :: init_val 0)
 
 let rec store_contents ptr = function
     Cop(Calloc, fields) ->
@@ -241,21 +258,32 @@ let rec transl = function
       Cvar id
   | Uconst sc ->
       transl_constant sc
-  | Uclosure(lbl, arity, params, body, clos_vars) ->
-      Queue.add (lbl, params, body) functions;
-      if arity = 1 then
-        Cop(Calloc,
-            Cconst_int(closure_header(2 + List.length clos_vars)) ::
-            Cconst_symbol lbl ::
+  | Uclosure(fundecls, clos_vars) ->
+      let block_size =
+        fundecls_size fundecls + List.length clos_vars in
+      let rec transl_fundecls pos = function
+        [] ->
+          List.map transl clos_vars
+      | (label, arity, params, body) :: rem ->
+          Queue.add (label, params, body) functions;
+          let header =
+            if pos = 0
+            then alloc_closure_header block_size
+            else alloc_infix_header pos in
+          if arity = 1 then
+            header ::
+            Cconst_symbol label ::
             int_const 1 ::
-            List.map transl clos_vars)
-      else
-        Cop(Calloc,
-            Cconst_int(closure_header(3 + List.length clos_vars)) ::
+            transl_fundecls (pos + 3) rem
+          else
+            header ::
             Cconst_symbol(curry_function arity) ::
             int_const arity ::
-            Cconst_symbol(lbl) ::
-            List.map transl clos_vars)
+            Cconst_symbol label ::
+            transl_fundecls (pos + 4) rem in
+      Cop(Calloc, transl_fundecls 0 fundecls)
+  | Uoffset(arg, offset) ->
+      field_address (transl arg) offset
   | Udirect_apply(lbl, args) ->
       Cop(Capply typ_addr, Cconst_symbol lbl :: List.map transl args)
   | Ugeneric_apply(clos, [arg]) ->
@@ -289,7 +317,7 @@ let rec transl = function
   | Uprim(Pmakeblock tag, []) ->
       transl_constant(Const_block(tag, []))
   | Uprim(Pmakeblock tag, args) ->
-      Cop(Calloc, Cconst_int(block_header tag (List.length args)) ::
+      Cop(Calloc, alloc_block_header tag (List.length args) ::
                   List.map transl args)
   | Uprim(Pfield n, [arg]) ->
       get_field (transl arg) n
@@ -369,7 +397,8 @@ let rec transl = function
                       [add_int (transl arg1) (untag_int(transl arg2));
                        transl arg3]))
   | Uprim(Pvectlength, [arg]) ->
-      tag_int(Cop(Clsr, [get_field (transl arg) (-1); Cconst_int 10]))
+      Cop(Cor, [Cop(Clsr, [get_field (transl arg) (-1); Cconst_int 10]);
+                Cconst_int 1])
   | Uprim(Pgetvectitem, [arg1; arg2]) ->
       Cop(Cload typ_addr, [array_indexing (transl arg1) (transl arg2)])
   | Uprim(Psetvectitem, [arg1; arg2; arg3]) ->
@@ -657,7 +686,7 @@ let rec intermediate_curry_functions arity num =
      {fun_name = name2;
       fun_args = [arg, typ_addr; clos, typ_addr];
       fun_body = Cop(Calloc,
-                     [Cconst_int(closure_header 4); 
+                     [alloc_closure_header 4; 
                       Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1));
                       int_const 1; Cvar arg; Cvar clos]);
       fun_fast = true}
diff --git a/asmcomp/emit_alpha.mlp b/asmcomp/emit_alpha.mlp
index d590e3d9d..b20805cf5 100644
--- a/asmcomp/emit_alpha.mlp
+++ b/asmcomp/emit_alpha.mlp
@@ -44,6 +44,36 @@ let emit_addressing addr r n =
   | Ibased(s, ofs) ->
       `{emit_symbol s} + {emit_int ofs}`
 
+(* Communicate live registers at call points to the assembler *)
+
+let int_reg_number = [|
+  0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12;
+  16; 17; 18; 19; 20; 21; 22; 23
+|]
+  
+let float_reg_number = [|
+  0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15;
+  16; 17; 18; 19; 20; 21; 22; 23; 24; 25; 26; 27; 28; 29
+|]
+
+let liveregs instr extra_msk =
+  (* $13, $14, $15, $26 always live *)
+  let int_mask = ref(0x00070020 lor extra_msk)
+  and float_mask = ref 0 in
+  let add_register = function
+      {loc = Reg r; typ = (Int | Addr)} ->
+        int_mask := !int_mask lor (1 lsl (31 - int_reg_number.(r)))
+    | {loc = Reg r; typ = Float} ->
+        float_mask := !float_mask lor (1 lsl (31 - float_reg_number.(r - 100)))
+    | _ -> () in
+  Reg.Set.iter add_register instr.live;
+  Array.iter add_register instr.arg;
+  emit_printf "	.livereg 0x%08x, 0x%08x\n" !int_mask !float_mask
+
+let live_24 = 1 lsl (31 - 24)
+let live_25 = 1 lsl (31 - 25)
+let live_27 = 1 lsl (31 - 27)
+
 (* Record live pointers at call points *)
 
 type frame_descr =
@@ -59,7 +89,7 @@ let record_frame_label live =
   Reg.Set.iter
     (function
         {typ = Addr; loc = Reg r} ->
-          live_offset := (-1 - r) :: !live_offset
+          live_offset := (-1 - int_reg_number.(r)) :: !live_offset
       | {typ = Addr; loc = Stack s} as reg ->
           live_offset := slot_offset s (register_class reg) :: !live_offset
       | _ -> ())
@@ -83,47 +113,13 @@ let emit_frame fd =
     fd.fd_live_offset;
   `	.align	3\n`
 
-(* Communicate live registers at call points to the assembler *)
-
-let int_reg_number = [|
-  (* 0-8 *)    0; 1; 2; 3; 4; 5; 6; 7; 8;
-  (* 9-12 *)   9; 10; 11; 12;
-  (* 13-18 *)  16; 17; 18; 19; 20; 21;
-  (* 19-21 *)  22; 23; 31
-|]
-  
-let float_reg_number = [|
-  (* 100-107 *) 0; 1; 10; 11; 12; 13; 14; 15;
-  (* 108-115 *) 2; 3; 4; 5; 6; 7; 8; 9;
-  (* 116-121 *) 16; 17; 18; 19; 20; 21;
-  (* 122-127 *) 22; 23; 24; 25; 26; 27;
-  (* 128-129 *) 28; 29
-|]
-
-let liveregs instr extra_msk =
-  (* $13, $14, $15, $26 always live *)
-  let int_mask = ref(0x00070020 lor extra_msk)
-  and float_mask = ref 0 in
-  let add_register = function
-      {loc = Reg r; typ = (Int | Addr)} ->
-        int_mask := !int_mask lor (1 lsl (31 - int_reg_number.(r)))
-    | {loc = Reg r; typ = Float} ->
-        float_mask := !float_mask lor (1 lsl (31 - float_reg_number.(r - 100)))
-    | _ -> () in
-  Reg.Set.iter add_register instr.live;
-  Array.iter add_register instr.arg;
-  emit_printf "	.livereg 0x%08x, 0x%08x\n" !int_mask !float_mask
-
-let live_24 = 1 lsl (31 - 24)
-let live_25 = 1 lsl (31 - 25)
-let live_27 = 1 lsl (31 - 27)
-
 (* Record calls to the GC -- we've moved them out of the way *)
 
 type gc_call =
   { gc_lbl: label;                      (* Entry label *)
     gc_return_lbl: label;               (* Where to branch after GC *)
     gc_desired_size: int;               (* Required block size *)
+    gc_frame: label;                    (* Label of frame descriptor *)
     gc_instr: instruction }             (* Record live registers *)
 
 let call_gc_sites = ref ([] : gc_call list)
@@ -131,7 +127,7 @@ let call_gc_sites = ref ([] : gc_call list)
 let emit_call_gc gc =
   `{emit_label gc.gc_lbl}:	ldiq	$25, {emit_int gc.gc_desired_size}\n`;
   liveregs gc.gc_instr 0;
-  `	bsr	caml_call_gc\n`;
+  `{emit_label gc.gc_frame}:	bsr	caml_call_gc\n`;
   `	br	{emit_label gc.gc_return_lbl}\n`
 
 (* Record calls to caml_fast_modify -- we've moved then out of the way *)
@@ -294,11 +290,11 @@ let emit_instr i =
           try
             let entry_point = Hashtbl.find nogp_entry_points s in
             liveregs i 0;
-            `	br	{emit_label entry_point}\n`
+            `	br	{emit_label entry_point} # {emit_symbol s}\n`
           with Not_found ->
             `	lda	$27, {emit_symbol s}\n`;
             liveregs i live_27;
-            `	jmp	{emit_symbol s}\n`
+            `	br      {emit_symbol s}\n`
         end
     | Lop(Iextcall s) ->
         `	lda	$25, {emit_symbol s}\n`;
@@ -330,12 +326,14 @@ let emit_instr i =
           let lbl_cont = new_label() in
           `	subq	$13, {emit_int n}, $13\n`;
           `	cmpult	$13, $14, $25\n`;
-          let lbl_call_gc = record_frame_label i.live in
+          let lbl_call_gc = new_label() in
+          let lbl_frame = record_frame_label i.live in
           `	bne	$25, {emit_label lbl_call_gc}\n`;
           call_gc_sites :=
             { gc_lbl = lbl_call_gc;
               gc_return_lbl = lbl_cont;
               gc_desired_size = n;
+              gc_frame = lbl_frame;
               gc_instr = i } :: !call_gc_sites;
           `{emit_label lbl_cont}:	addq	$13, 8, {emit_reg i.res.(0)}\n`
         end else begin
@@ -484,10 +482,17 @@ let emit_instr i =
             done;
             `	.text\n`
         end
-    | Lpushtrap lbl ->
+    | Lsetuptrap lbl ->
+        `	br	$25, {emit_label lbl}\n`;
+        (* This global label helps pixie understand what's going up *)
+        let handler_label =
+          Compilenv.current_unit_name() ^ "_exception_" ^ string_of_int lbl in
+        `	.globl	{emit_symbol handler_label}\n`;
+        `{emit_symbol handler_label}:\n`;
+        `	ldgp	$gp, 0($27)\n`
+    | Lpushtrap ->
         stack_offset := !stack_offset + 16;
         `	lda	$sp, -16($sp)\n`;
-        `	lda	$25, {emit_label lbl}\n`;
         `	stq	$15, 0($sp)\n`;
         `	stq	$25, 8($sp)\n`;
         `	mov	$sp, $15\n`
@@ -495,15 +500,14 @@ let emit_instr i =
         `	ldq	$15, 0($sp)\n`;
         `	lda	$sp, 16($sp)\n`;
         stack_offset := !stack_offset - 16
-    | Lentertrap ->
-        `	ldgp	$gp, 0($27)\n`
     | Lraise ->
         `	mov	$15, $sp\n`;
         `	ldq	$15, 0($sp)\n`;
         `	ldq	$27, 8($sp)\n`;
         `	lda	$sp, 16($sp)\n`;
         liveregs i 0;
-        `	jmp	($27)\n`
+        `	jmp	$26, ($27)\n`
+        (* Keep address of raise in $26 for debugging purposes *)
 
 let rec emit_all i =
   match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next
@@ -584,13 +588,28 @@ let data l =
 
 (* Beginning / end of an assembly file *)
 
-let begin_assembly() = ()
+let begin_assembly() =
+  (* There are really two groups of registers:
+      $sp and $15 always point to stack locations
+      $0 - $14, $16-$23 never point to stack locations. *)
+  `	.noalias $0,$sp;  .noalias $0,$15;  .noalias $1,$sp;  .noalias $1,$15\n`;
+  `	.noalias $2,$sp;  .noalias $2,$15;  .noalias $3,$sp;  .noalias $3,$15\n`;
+  `	.noalias $4,$sp;  .noalias $4,$15;  .noalias $5,$sp;  .noalias $5,$15\n`;
+  `	.noalias $6,$sp;  .noalias $6,$15;  .noalias $7,$sp;  .noalias $7,$15\n`;
+  `	.noalias $8,$sp;  .noalias $8,$15;  .noalias $9,$sp;  .noalias $9,$15\n`;
+  `	.noalias $10,$sp; .noalias $10,$15; .noalias $11,$sp; .noalias $11,$15\n`;
+  `	.noalias $12,$sp; .noalias $12,$15; .noalias $13,$sp; .noalias $13,$15\n`;
+  `	.noalias $14,$sp; .noalias $14,$15; .noalias $16,$sp; .noalias $16,$15\n`;
+  `	.noalias $17,$sp; .noalias $17,$15; .noalias $18,$sp; .noalias $18,$15\n`;
+  `	.noalias $19,$sp; .noalias $19,$15; .noalias $20,$sp; .noalias $20,$15\n`;
+  `	.noalias $21,$sp; .noalias $21,$15; .noalias $22,$sp; .noalias $22,$15\n`;
+  `	.noalias $23,$sp; .noalias $23,$15\n\n`
 
 let end_assembly () =
   let lbl = Compilenv.current_unit_name() ^ "_frametable" in
   `	.rdata\n`;
   `	.globl	{emit_symbol lbl}\n`;
   `{emit_symbol lbl}:\n`;
+  `	.quad	{emit_int (List.length !frame_descriptors)}\n`;
   List.iter emit_frame !frame_descriptors;
-  frame_descriptors := [];
-  `	.quad	0\n`
+  frame_descriptors := []
diff --git a/asmcomp/emit_i386.mlp b/asmcomp/emit_i386.mlp
index 198f4a60c..c9f52db07 100644
--- a/asmcomp/emit_i386.mlp
+++ b/asmcomp/emit_i386.mlp
@@ -506,6 +506,6 @@ let end_assembly() =
   `	.data\n`;
   `	.globl	{emit_symbol lbl}\n`;
   `{emit_symbol lbl}:\n`;
+  `	.long	{emit_int (List.length !frame_descriptors)}\n`;
   List.iter emit_frame !frame_descriptors;
-  frame_descriptors := [];
-  `	.long	0\n`
+  frame_descriptors := []
diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml
index 24b42b24d..4e17b1b50 100644
--- a/asmcomp/linearize.ml
+++ b/asmcomp/linearize.ml
@@ -23,9 +23,9 @@ and instruction_desc =
   | Lbranch of label
   | Lcondbranch of test * label
   | Lswitch of label array
-  | Lpushtrap of label
+  | Lsetuptrap of label
+  | Lpushtrap
   | Lpoptrap
-  | Lentertrap
   | Lraise
 
 type fundecl =
@@ -162,12 +162,12 @@ let rec linear i n =
   | Iexit ->
       add_branch !exit_label (linear i.Mach.next n)
   | Itrywith(body, handler) ->
-      let (lbl_end, n1) = get_label(linear i.Mach.next n) in
-      let (lbl_handler, n2) =
-        get_label(cons_instr Lentertrap (linear handler n1)) in
-      cons_instr (Lpushtrap lbl_handler)
-        (linear body
-          (cons_instr Lpoptrap (add_branch lbl_end n2)))
+      let (lbl_join, n1) = get_label (linear i.Mach.next n) in
+      let (lbl_body, n2) =
+        get_label (cons_instr Lpushtrap
+                    (linear body (cons_instr Lpoptrap n1))) in
+      cons_instr (Lsetuptrap lbl_body)
+        (linear handler (add_branch lbl_join n2))
   | Iraise ->
       copy_instr Lraise i n
 
diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli
index 97e83ac06..e51f2aebd 100644
--- a/asmcomp/linearize.mli
+++ b/asmcomp/linearize.mli
@@ -18,9 +18,9 @@ and instruction_desc =
   | Lbranch of label
   | Lcondbranch of Mach.test * label
   | Lswitch of label array
-  | Lpushtrap of label
+  | Lsetuptrap of label
+  | Lpushtrap
   | Lpoptrap
-  | Lentertrap
   | Lraise
 
 type fundecl =
diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml
index 7260106bb..c2a19dcd5 100644
--- a/asmcomp/liveness.ml
+++ b/asmcomp/liveness.ml
@@ -73,17 +73,19 @@ let rec live i finally =
       (* i.live remains empty since no regs are live across *)
       Reg.add_set_array !live_at_raise i.arg
   | _ ->
-      let across = Reg.diff_set_array (live i.next finally) i.res in
+      let across_after = Reg.diff_set_array (live i.next finally) i.res in
+      let across =
+        match i.desc with
+          Iop(Icall_ind) | Iop(Icall_imm _) | Iop(Iextcall _)->
+            (* The function call may raise an exception, branching to the
+               nearest enclosing try ... with. Hence, everything that must
+               be live at the beginning of the exception handler must also
+               be live across the call. *)
+             Reg.Set.union across_after !live_at_raise
+         | _ ->
+             across_after in
       i.live <- across;
-      match i.desc with
-        Iop(Icall_ind) | Iop(Icall_imm _) | Iop(Iextcall _)->
-          (* The function call may raise an exception, branching to the
-             nearest enclosing try ... with. Hence, everything that must
-             be live at the beginning of the exception handler must also
-             be live just before the call. *)
-           Reg.add_set_array (Reg.Set.union across !live_at_raise) i.arg
-       | _ ->
-           Reg.add_set_array across i.arg
+      Reg.add_set_array across i.arg
 
 let fundecl f =
   live f.fun_body Reg.Set.empty; ()
diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml
index ec406d824..0250dd980 100644
--- a/asmcomp/printcmm.ml
+++ b/asmcomp/printcmm.ml
@@ -170,7 +170,7 @@ let rec expression = function
       open_hovbox 2;
       print_string "(catch";
       print_space(); sequence e1;
-      print_break(1, -2); print_string "with";
+      print_break 1 (-2); print_string "with";
       print_space(); sequence e2;
       print_string ")"; close_box()
   | Cexit ->
@@ -179,7 +179,7 @@ let rec expression = function
       open_hovbox 2;
       print_string "(try";
       print_space(); sequence e1;
-      print_break(1, -2); print_string "with "; Ident.print id;
+      print_break 1 (-2); print_string "with "; Ident.print id;
       print_space(); sequence e2;
       print_string ")"; close_box()
 
@@ -191,7 +191,7 @@ and sequence = function
 
 let fundecl f =
   open_hovbox 1;
-  print_string "(function "; print_string f.fun_name; print_break(1,4);
+  print_string "(function "; print_string f.fun_name; print_break 1 4;
   open_hovbox 1;
   print_string "(";
   let first = ref true in
diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml
index 71d705175..e351e3bc4 100644
--- a/asmcomp/printlinear.ml
+++ b/asmcomp/printlinear.ml
@@ -1,6 +1,7 @@
 (* Pretty-printing of linearized machine code *)
 
 open Format
+open Mach
 open Printmach
 open Linearize
 
@@ -11,6 +12,16 @@ let instr i =
   match i.desc with
     Lend -> ()
   | Lop op ->
+      begin match op with
+        Ialloc _ | Icall_ind | Icall_imm _ | Iextcall _ ->
+          open_hovbox 1;
+          print_string "{";
+          regsetaddr i.live;
+          print_string "}";
+          close_box();
+          print_cut()
+      | _ -> ()
+      end;
       operation op i.arg i.res
   | Lreturn ->
       print_string "return "; regs i.arg
@@ -28,12 +39,12 @@ let instr i =
         print_string ": goto "; label lblv.(i)
       done;
       print_cut(); print_string "endswitch"
-  | Lpushtrap lbl ->
-      print_string "push trap "; label lbl
+  | Lsetuptrap lbl ->
+      print_string "setup trap "; label lbl
+  | Lpushtrap ->
+      print_string "push trap"
   | Lpoptrap ->
       print_string "pop trap"
-  | Lentertrap ->
-      print_string "enter trap"
   | Lraise ->
       print_string "raise "; reg i.arg.(0)
 
diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml
index ff97b6522..ae72c374b 100644
--- a/asmcomp/printmach.ml
+++ b/asmcomp/printmach.ml
@@ -39,6 +39,15 @@ let regset s =
       reg r)
     s
 
+let regsetaddr s =
+  let first = ref true in
+  Reg.Set.iter
+    (fun r ->
+      if !first then first := false else print_space();
+      reg r;
+      match r.typ with Addr -> print_string "*" | _ -> ())
+    s
+
 let intcomp = function
     Isigned c -> print_string " "; Printcmm.comparison c; print_string "s "
   | Iunsigned c -> print_string " "; Printcmm.comparison c; print_string "u "
@@ -119,7 +128,7 @@ let rec instr i =
   if !print_live then begin
     open_hovbox 1;
     print_string "{";
-    regset i.live;
+    regsetaddr i.live;
     if Array.length i.arg > 0 then begin
       print_space(); print_string "+"; print_space(); regs i.arg
     end;
@@ -139,9 +148,9 @@ let rec instr i =
       instr ifso;
       begin match ifnot.desc with
         Iend -> ()
-      | _ -> print_break(0, -2); print_string "else"; print_cut(); instr ifnot
+      | _ -> print_break 0 (-2); print_string "else"; print_cut(); instr ifnot
       end;
-      print_break(0, -2); print_string "endif";
+      print_break 0 (-2); print_string "endif";
       close_box()
   | Iswitch(index, cases) ->
       print_string "switch "; reg i.arg.(0);
@@ -163,16 +172,16 @@ let rec instr i =
   | Iloop(body) ->
       open_vbox 2;
       print_string "loop"; print_cut();
-      instr body; print_break(0, -2); 
+      instr body; print_break 0 (-2); 
       print_string "endloop ";
       close_box()
   | Icatch(body, handler) ->
       open_vbox 2;
       print_string "catch"; print_cut();
       instr body;
-      print_break(0, -2);  print_string "with"; print_cut();
+      print_break 0 (-2);  print_string "with"; print_cut();
       instr handler;
-      print_break(0, -2); print_string "endcatch";
+      print_break 0 (-2); print_string "endcatch";
       close_box()
   | Iexit ->
       print_string "exit"
@@ -180,9 +189,9 @@ let rec instr i =
       open_vbox 2;
       print_string "try"; print_cut();
       instr body;
-      print_break(0, -2);  print_string "with"; print_cut();
+      print_break 0 (-2);  print_string "with"; print_cut();
       instr handler;
-      print_break(0, -2); print_string "endtry";
+      print_break 0 (-2); print_string "endtry";
       close_box()
   | Iraise ->
       print_string "raise "; reg i.arg.(0)
diff --git a/asmcomp/printmach.mli b/asmcomp/printmach.mli
index c9d4f7448..63edbe7ae 100644
--- a/asmcomp/printmach.mli
+++ b/asmcomp/printmach.mli
@@ -3,6 +3,7 @@
 val reg: Reg.t -> unit
 val regs: Reg.t array -> unit
 val regset: Reg.Set.t -> unit
+val regsetaddr: Reg.Set.t -> unit
 val operation: Mach.operation -> Reg.t array -> Reg.t array -> unit
 val test: Mach.test -> Reg.t array -> unit
 val instr: Mach.instruction -> unit
diff --git a/asmcomp/proc_alpha.ml b/asmcomp/proc_alpha.ml
index 6057dbc16..cdbf0387d 100644
--- a/asmcomp/proc_alpha.ml
+++ b/asmcomp/proc_alpha.ml
@@ -54,38 +54,33 @@ let is_immediate (n:int) = true
 
 (* Register map:
     $0 - $7     0 - 7       function results
-    $8          8           general purpose
-    $9 - $12    9 - 12      function arguments ($9 - $15 are preserved by C)
+    $8 - $12    8 - 12      general purpose ($9 - $15 are preserved by C)
     $13                     allocation pointer
     $14                     allocation limit
     $15                     trap pointer
-    $16 - $21   13 - 18     more function arguments, C function arguments
-    $22 - $23   19 - 20     more function arguments
+    $16 - $23   13 - 20     function arguments
     $24, $25                temporaries
     $26-$30                 stack ptr, global ptr, etc
     $31         21          always zero
 
-    $f0 - $f1   100 - 101   function results
-    $f10 - $f15 102 - 107   more function results
-    $f2 - $f9   108 - 115   function arguments ($f2 - $f9 preserved by C)
-    $f16 - $f21 116 - 121   C function arguments
-    $f22 - $f29 122 - 129   general purpose
+    $f0 - $f7   100 - 107   function results
+    $f8 - $f15  108 - 115   general purpose ($f2 - $f9 preserved by C)
+    $f16 - $f23 116 - 123   function arguments
+    $f24 - $f29 124 - 129   general purpose
     $f30                    temporary
     $f31                    always zero *)
 
 let int_reg_name = [|
-  (* 0-8 *)    "$0"; "$1"; "$2"; "$3"; "$4"; "$5"; "$6"; "$7"; "$8";
-  (* 9-12 *)   "$9"; "$10"; "$11"; "$12";
-  (* 13-18 *)  "$16"; "$17"; "$18"; "$19"; "$20"; "$21";
-  (* 19-21 *)  "$22"; "$23"; "$31"
+  (* 0-7 *)    "$0"; "$1"; "$2"; "$3"; "$4"; "$5"; "$6"; "$7";
+  (* 8-12 *)   "$8"; "$9"; "$10"; "$11"; "$12";
+  (* 13-20 *)  "$16"; "$17"; "$18"; "$19"; "$20"; "$21"; "$22"; "$23"
 |]
   
 let float_reg_name = [|
-  (* 100-107 *)"$f0"; "$f1"; "$f10"; "$f11"; "$f12"; "$f13"; "$f14"; "$f15";
-  (* 108-115 *)"$f2"; "$f3"; "$f4"; "$f5"; "$f6"; "$f7"; "$f8"; "$f9";
-  (* 116-121 *)"$f16"; "$f17"; "$f18"; "$f19"; "$f20"; "$f21";
-  (* 122-127 *)"$f22"; "$f23"; "$f24"; "$f25"; "$f26"; "$f27";
-  (* 128-129 *)"$f28"; "$f29"
+  (* 100-107 *) "$f0"; "$f1"; "$f2"; "$f3"; "$f4"; "$f5"; "$f6"; "$f7";
+  (* 108-115 *) "$f8"; "$f9"; "$f10"; "$f11"; "$f12"; "$f13"; "$f14"; "$f15";
+  (* 116-123 *) "$f16"; "$f17"; "$f18"; "$f19"; "$f20"; "$f21"; "$f22"; "$f23";
+  (* 124-129 *) "$f24"; "$f25"; "$f26"; "$f27"; "$f28"; "$f29"
 |]
 
 let num_register_classes = 2
@@ -158,9 +153,9 @@ let outgoing ofs = Outgoing ofs
 let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
 
 let loc_arguments arg =
-  calling_conventions 9 20 108 115 outgoing arg
+  calling_conventions 13 18 116 123 outgoing arg
 let loc_parameters arg =
-  let (loc, ofs) = calling_conventions 9 20 108 115 incoming arg in loc
+  let (loc, ofs) = calling_conventions 13 18 116 123 incoming arg in loc
 let loc_results res =
   let (loc, ofs) = calling_conventions 0 7 100 107 not_supported res in loc
 
@@ -240,4 +235,4 @@ let slot_offset loc class =
 (* Calling the assembler *)
 
 let assemble_file infile outfile =
-  Sys.command ("as -O2 -o " ^ outfile ^ " " ^ infile)
+  Sys.command ("as -nocpp -O2 -o " ^ outfile ^ " " ^ infile)
diff --git a/asmcomp/reload.ml b/asmcomp/reload.ml
index 09f91fb55..1425e689d 100644
--- a/asmcomp/reload.ml
+++ b/asmcomp/reload.ml
@@ -43,8 +43,6 @@ let insert_moves src dst next =
 let rec reload i =
   match i.desc with
     Iend | Ireturn | Iop Itailcall_ind | Iop(Itailcall_imm _) | Iraise -> i
-  | Iop(Icall_ind) | Iop(Icall_imm _) | Iop(Iextcall _) ->
-      instr_cons i.desc i.arg i.res (reload i.next)
   | Iop(Imove | Ireload | Ispill) ->
       (* Do something if this is a stack-to-stack move *)
       begin match i.arg.(0), i.res.(0) with
diff --git a/asmcomp/selection.ml b/asmcomp/selection.ml
index 70eb0b928..3d6d70b93 100644
--- a/asmcomp/selection.ml
+++ b/asmcomp/selection.ml
@@ -524,26 +524,37 @@ let rec emit_tail env exp seq =
       let (new_op, new_args) = sel_operation op simple_args in
       begin match new_op with
         Icall_ind ->
-          Proc.contains_calls := true;
           let r1 = emit_tuple env new_args seq in
           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
-            emit_return env exp seq
-          else begin
+          if stack_ofs = 0 then begin
             insert_moves rarg loc_arg seq;
             insert (Iop Itailcall_ind)
                    (Array.append [|r1.(0)|] loc_arg) [||] seq
+          end else begin
+            Proc.contains_calls := true;
+            let rd = Reg.newv ty in
+            let loc_res = Proc.loc_results rd in
+            insert_move_args rarg loc_arg stack_ofs seq;
+            insert (Iop Icall_ind)
+                   (Array.append [|r1.(0)|] loc_arg) loc_res seq;
+            insert(Iop(Istackoffset(-stack_ofs))) [||] [||] seq;
+            insert Ireturn loc_res [||] seq
           end
       | Icall_imm lbl ->
-          Proc.contains_calls := true;
           let r1 = emit_tuple env new_args seq in
           let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in
-          if stack_ofs <> 0 then
-            emit_return env exp seq
-          else begin
+          if stack_ofs = 0 then begin
             insert_moves r1 loc_arg seq;
             insert (Iop(Itailcall_imm lbl)) loc_arg [||] seq
+          end else begin
+            Proc.contains_calls := true;
+            let rd = Reg.newv ty in
+            let loc_res = Proc.loc_results rd in
+            insert_move_args r1 loc_arg stack_ofs seq;
+            insert (Iop(Icall_imm lbl)) loc_arg loc_res seq;
+            insert(Iop(Istackoffset(-stack_ofs))) [||] [||] seq;
+            insert Ireturn loc_res [||] seq
           end
       | _ -> fatal_error "Selection.emit_tail"
       end