merge changes from release/3.11.1 to release/3.11.2

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

3 files changed, 75 insertions, 39 deletions

diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml
index 19a2c5268e..ede7bb9770 100644
--- a/bytecomp/bytelink.ml
+++ b/bytecomp/bytelink.ml
@@ -377,14 +377,40 @@ let output_data_string outchan data =
     end
   done
 
+(* Output a debug stub *)
+
+let output_cds_file outfile =
+  Misc.remove_file outfile;
+  let outchan =
+    open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary]
+      0o777 outfile in
+  try
+    Bytesections.init_record outchan;
+    (* The map of global identifiers *)
+    Symtable.output_global_map outchan;
+    Bytesections.record outchan "SYMB";
+    (* Debug info *)
+    output_debug_info outchan;
+    Bytesections.record outchan "DBUG";
+    (* The table of contents and the trailer *)
+    Bytesections.write_toc_and_trailer outchan;
+    close_out outchan
+  with x ->
+    close_out outchan;
+    remove_file outfile;
+    raise x
+
 (* Output a bytecode executable as a C file *)
 
 let link_bytecode_as_c tolink outfile =
   let outchan = open_out outfile in
-  try
+  begin try
     (* The bytecode *)
-    output_string outchan "#include <caml/mlvalues.h>\n";
     output_string outchan "\
+#ifdef __cplusplus\n\
+extern \"C\" {\n\
+#endif\n\
+#include <caml/mlvalues.h>\n\
 CAMLextern void caml_startup_code(\n\
            code_t code, asize_t code_size,\n\
            char *data, asize_t data_size,\n\
@@ -393,8 +419,11 @@ CAMLextern void caml_startup_code(\n\
     output_string outchan "static int caml_code[] = {\n";
     Symtable.init();
     Consistbl.clear crc_interfaces;
-    let output_fun = output_code_string outchan
-    and currpos_fun () = 0 in
+    let currpos = ref 0 in
+    let output_fun code =
+      output_code_string outchan code;
+      currpos := !currpos + String.length code
+    and currpos_fun () = !currpos in
     List.iter (link_file output_fun currpos_fun) tolink;
     (* The final STOP instruction *)
     Printf.fprintf outchan "\n0x%x};\n\n" Opcodes.opSTOP;
@@ -422,18 +451,24 @@ void caml_startup(char ** argv)\n\
                     caml_data, sizeof(caml_data),\n\
                     caml_sections, sizeof(caml_sections),\n\
                     argv);\n\
-}\n";
+}\n\
+#ifdef __cplusplus\n\
+}\n\
+#endif\n";
     close_out outchan
   with x ->
     close_out outchan;
     raise x
+  end;
+  if !Clflags.debug then
+    output_cds_file ((Filename.chop_extension outfile) ^ ".cds")
 
 (* Build a custom runtime *)
 
 let build_custom_runtime prim_name exec_name =
   Ccomp.call_linker Ccomp.Exe exec_name
     ([prim_name] @ List.rev !Clflags.ccobjs @ ["-lcamlrun"])
-    Config.bytecomp_c_libraries
+    (Clflags.std_include_flag "-I" ^ " " ^ Config.bytecomp_c_libraries)
 
 let append_bytecode_and_cleanup bytecode_name exec_name prim_name =
   let oc = open_out_gen [Open_wronly; Open_append; Open_binary] 0 exec_name in
@@ -472,7 +507,20 @@ let link objfiles output_name =
     try
       link_bytecode tolink bytecode_name false;
       let poc = open_out prim_name in
+      output_string poc "\
+        #ifdef __cplusplus\n\
+        extern \"C\" {\n\
+        #endif\n\
+        #ifdef _WIN64\n\
+        typedef __int64 value;\n\
+        #else\n\
+        typedef long value;\n\
+        #endif\n";
       Symtable.output_primitive_table poc;
+      output_string poc "\
+        #ifdef __cplusplus\n\
+        }\n\
+        #endif\n";
       close_out poc;
       let exec_name = fix_exec_name output_name in
       if not (build_custom_runtime prim_name exec_name)
diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml
index 1538451634..bad39a2135 100644
--- a/bytecomp/symtable.ml
+++ b/bytecomp/symtable.ml
@@ -114,14 +114,10 @@ open Printf
 
 let output_primitive_table outchan =
   let prim = all_primitives() in
-  fprintf outchan "\
-    #ifdef __cplusplus\n\
-    extern \"C\" {\n\
-    #endif\n";
   for i = 0 to Array.length prim - 1 do
-    fprintf outchan "extern long %s();\n" prim.(i)
+    fprintf outchan "extern value %s();\n" prim.(i)
   done;
-  fprintf outchan "typedef long (*primitive)();\n";
+  fprintf outchan "typedef value (*primitive)();\n";
   fprintf outchan "primitive caml_builtin_cprim[] = {\n";
   for i = 0 to Array.length prim - 1 do
     fprintf outchan "  %s,\n" prim.(i)
@@ -131,11 +127,7 @@ let output_primitive_table outchan =
   for i = 0 to Array.length prim - 1 do
     fprintf outchan "  \"%s\",\n" prim.(i)
   done;
-  fprintf outchan "  (char *) 0 };\n";
-  fprintf outchan "\
-    #ifdef __cplusplus\n\
-    }\n\
-    #endif\n"
+  fprintf outchan "  (char *) 0 };\n"
 
 (* Initialization for batch linking *)
 
diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml
index f905cc26d9..ebcfb20a90 100644
--- a/bytecomp/typeopt.ml
+++ b/bytecomp/typeopt.ml
@@ -22,18 +22,17 @@ open Types
 open Typedtree
 open Lambda
 
+let scrape env ty =
+  (Ctype.repr (Ctype.expand_head_opt env (Ctype.correct_levels ty))).desc
+
 let has_base_type exp base_ty_path =
-  let exp_ty =
-    Ctype.expand_head_opt exp.exp_env (Ctype.correct_levels exp.exp_type) in
-  match Ctype.repr exp_ty with
-    {desc = Tconstr(p, _, _)} -> Path.same p base_ty_path
+  match scrape exp.exp_env exp.exp_type with
+  | Tconstr(p, _, _) -> Path.same p base_ty_path
   | _ -> false
 
 let maybe_pointer exp =
-  let exp_ty =
-    Ctype.expand_head_opt exp.exp_env (Ctype.correct_levels exp.exp_type) in
-  match (Ctype.repr exp_ty).desc with
-    Tconstr(p, args, abbrev) ->
+  match scrape exp.exp_env exp.exp_type with
+  | Tconstr(p, args, abbrev) ->
       not (Path.same p Predef.path_int) &&
       not (Path.same p Predef.path_char) &&
       begin try
@@ -50,9 +49,8 @@ let maybe_pointer exp =
   | _ -> true
 
 let array_element_kind env ty =
-  let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
-  match ty.desc with
-    Tvar | Tunivar ->
+  match scrape env ty with
+  | Tvar | Tunivar ->
       Pgenarray
   | Tconstr(p, args, abbrev) ->
       if Path.same p Predef.path_int || Path.same p Predef.path_char then
@@ -85,9 +83,8 @@ let array_element_kind env ty =
       Paddrarray
 
 let array_kind_gen ty env =
-  let array_ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in
-  match (Ctype.repr array_ty).desc with
-    Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _)
+  match scrape env ty with
+  | Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _)
     when Path.same p Predef.path_array ->
       array_element_kind env elt_ty
   | _ ->
@@ -98,9 +95,9 @@ let array_kind exp = array_kind_gen exp.exp_type exp.exp_env
 
 let array_pattern_kind pat = array_kind_gen pat.pat_type pat.pat_env
 
-let bigarray_decode_type ty tbl dfl =
-  match (Ctype.repr ty).desc with
-    Tconstr(Pdot(Pident mod_id, type_name, _), [], _)
+let bigarray_decode_type env ty tbl dfl =
+  match scrape env ty with
+  | Tconstr(Pdot(Pident mod_id, type_name, _), [], _)
     when Ident.name mod_id = "Bigarray" ->
       begin try List.assoc type_name tbl with Not_found -> dfl end
   | _ ->
@@ -125,10 +122,9 @@ let layout_table =
    "fortran_layout", Pbigarray_fortran_layout]
 
 let bigarray_kind_and_layout exp =
-  let ty = Ctype.repr (Ctype.expand_head_opt exp.exp_env exp.exp_type) in
-  match ty.desc with
-    Tconstr(p, [caml_type; elt_type; layout_type], abbrev) ->
-      (bigarray_decode_type elt_type kind_table Pbigarray_unknown,
-       bigarray_decode_type layout_type layout_table Pbigarray_unknown_layout)
+  match scrape exp.exp_env exp.exp_type with
+  | Tconstr(p, [caml_type; elt_type; layout_type], abbrev) ->
+      (bigarray_decode_type exp.exp_env elt_type kind_table Pbigarray_unknown,
+       bigarray_decode_type exp.exp_env layout_type layout_table Pbigarray_unknown_layout)
   | _ ->
       (Pbigarray_unknown, Pbigarray_unknown_layout)