diff -ru ocaml-4.00.0.orig/asmcomp/asmlink.ml ocaml-4.00.0/asmcomp/asmlink.ml --- ocaml-4.00.0.orig/asmcomp/asmlink.ml 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/asmcomp/asmlink.ml 2012-09-24 15:57:37.000000000 +0200 @@ -213,6 +213,7 @@ (fun name -> compile_phrase (Cmmgen.predef_exception name)) Runtimedef.builtin_exceptions; compile_phrase (Cmmgen.global_table name_list); + compile_phrase (Cmmgen.global_table_info name_list); compile_phrase (Cmmgen.globals_map (List.map diff -ru ocaml-4.00.0.orig/asmcomp/closure.ml ocaml-4.00.0/asmcomp/closure.ml --- ocaml-4.00.0.orig/asmcomp/closure.ml 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/asmcomp/closure.ml 2012-09-24 15:57:37.000000000 +0200 @@ -836,10 +836,14 @@ (* The entry point *) + let intro size lam = function_nesting_depth := 0; + + let m = Typeopt.extract_mem lam in + global_approx := Array.create size Value_unknown; Compilenv.set_global_approx(Value_tuple !global_approx); let (ulam, approx) = close Tbl.empty Tbl.empty lam in global_approx := [||]; - ulam + m, ulam diff -ru ocaml-4.00.0.orig/asmcomp/closure.mli ocaml-4.00.0/asmcomp/closure.mli --- ocaml-4.00.0.orig/asmcomp/closure.mli 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/asmcomp/closure.mli 2012-09-24 15:59:09.000000000 +0200 @@ -14,4 +14,4 @@ (* Introduction of closures, uncurrying, recognition of direct calls *) -val intro: int -> Lambda.lambda -> Clambda.ulambda +val intro: int -> Lambda.lambda -> Typeopt.mem_repr * Clambda.ulambda diff -ru ocaml-4.00.0.orig/asmcomp/cmmgen.ml ocaml-4.00.0/asmcomp/cmmgen.ml --- ocaml-4.00.0.orig/asmcomp/cmmgen.ml 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/asmcomp/cmmgen.ml 2012-09-24 16:01:06.000000000 +0200 @@ -1792,7 +1792,7 @@ (* Translate a compilation unit *) -let compunit size ulam = +let compunit size (hp_info,ulam) = let glob = Compilenv.make_symbol None in let init_code = transl ulam in let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry"); @@ -1801,10 +1801,16 @@ fun_dbg = Debuginfo.none }] in let c2 = transl_all_functions StringSet.empty c1 in let c3 = emit_all_constants c2 in + let hp_info = Marshal.to_string hp_info [] in +(* Printf.printf "HP Info: %d" (String.length hp_info); print_newline (); *) + let c4 = Cdata(Cglobal_symbol (glob ^ "_info") :: + emit_constant (glob ^ "_info") + (Const_base (Const_string hp_info)) []) in Cdata [Cint(block_header 0 size); Cglobal_symbol glob; Cdefine_symbol glob; - Cskip(size * size_addr)] :: c3 + Cskip(size * size_addr)] :: + c4 :: c3 (* CAMLprim value caml_cache_public_method (value meths, value tag, value *cache) @@ -2135,6 +2141,12 @@ List.map mksym namelist @ [cint_zero]) +let global_table_info namelist = + Cdata(Cglobal_symbol "caml_globals_info" :: + Cdefine_symbol "caml_globals_info" :: + List.map (fun name -> Csymbol_address ("caml" ^ name ^ "_info")) namelist @ + [cint_zero]) + let reference_symbols namelist = let mksym name = Csymbol_address name in Cdata(List.map mksym namelist) diff -ru ocaml-4.00.0.orig/asmcomp/cmmgen.mli ocaml-4.00.0/asmcomp/cmmgen.mli --- ocaml-4.00.0.orig/asmcomp/cmmgen.mli 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/asmcomp/cmmgen.mli 2012-09-24 16:00:12.000000000 +0200 @@ -14,7 +14,7 @@ (* Translation from closed lambda to C-- *) -val compunit: int -> Clambda.ulambda -> Cmm.phrase list +val compunit: int -> Typeopt.mem_repr * Clambda.ulambda -> Cmm.phrase list val apply_function: int -> Cmm.phrase val send_function: int -> Cmm.phrase @@ -22,6 +22,7 @@ val generic_functions: bool -> Cmx_format.unit_infos list -> Cmm.phrase list val entry_point: string list -> Cmm.phrase val global_table: string list -> Cmm.phrase +val global_table_info: string list -> Cmm.phrase val reference_symbols: string list -> Cmm.phrase val globals_map: (string * Digest.t * Digest.t * string list) list -> Cmm.phrase diff -ru ocaml-4.00.0.orig/asmrun/Makefile ocaml-4.00.0/asmrun/Makefile --- ocaml-4.00.0.orig/asmrun/Makefile 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/asmrun/Makefile 2012-09-24 16:19:31.000000000 +0200 @@ -18,7 +18,7 @@ CC=$(NATIVECC) FLAGS=-I../byterun -DCAML_NAME_SPACE -DNATIVE_CODE \ -DTARGET_$(ARCH) -DSYS_$(SYSTEM) $(IFLEXDIR) -CFLAGS=$(FLAGS) -O $(NATIVECCCOMPOPTS) +CFLAGS=$(FLAGS) -g -O $(NATIVECCCOMPOPTS) DFLAGS=$(FLAGS) -g -DDEBUG $(NATIVECCCOMPOPTS) PFLAGS=$(FLAGS) -pg -O -DPROFILING $(NATIVECCPROFOPTS) diff -ru ocaml-4.00.0.orig/asmrun/startup.c ocaml-4.00.0/asmrun/startup.c --- ocaml-4.00.0.orig/asmrun/startup.c 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/asmrun/startup.c 2012-09-24 16:20:00.000000000 +0200 @@ -117,6 +117,7 @@ } } +extern int heap_profiling; static void parse_camlrunparam(void) { char *opt = getenv ("OCAMLRUNPARAM"); @@ -136,6 +137,7 @@ case 'v': scanmult (opt, &caml_verb_gc); break; case 'b': caml_record_backtrace(Val_true); break; case 'p': caml_parser_trace = 1; break; + case 'm': heap_profiling = 1; break; case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break; } } Only in ocaml-4.00.0/boot: camlheader diff -ru ocaml-4.00.0.orig/bytecomp/translcore.ml ocaml-4.00.0/bytecomp/translcore.ml --- ocaml-4.00.0.orig/bytecomp/translcore.ml 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/bytecomp/translcore.ml 2012-09-24 16:18:40.000000000 +0200 @@ -664,10 +664,11 @@ Cstr_constant n -> Lconst(Const_pointer n) | Cstr_block n -> + Typeopt.record_representation e.exp_env e.exp_type; begin try - Lconst(Const_block(n, List.map extract_constant ll)) + Lconst(Const_block(cstr.cstr_alloc_tag (* n *), List.map extract_constant ll)) with Not_constant -> - Lprim(Pmakeblock(n, Immutable), ll) + Lprim(Pmakeblock(cstr.cstr_alloc_tag (* n *), Immutable), ll) end | Cstr_exception (path, _) -> Lprim(Pmakeblock(0, Immutable), transl_path path :: ll) @@ -686,7 +687,9 @@ [Lconst(Const_base(Const_int tag)); lam]) end | Texp_record ((_, _, lbl1, _) :: _ as lbl_expr_list, opt_init_expr) -> - transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr + let record_tag = lbl1.lbl_tag in + Typeopt.record_representation e.exp_env e.exp_type; + transl_record record_tag lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr | Texp_record ([], _) -> fatal_error "Translcore.transl_exp: bad Texp_record" | Texp_field(arg, _, _, lbl) -> @@ -956,7 +959,7 @@ Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray), [self; transl_path var; transl_exp expr]) -and transl_record all_labels repres lbl_expr_list opt_init_expr = +and transl_record record_tag all_labels repres lbl_expr_list opt_init_expr = let size = Array.length all_labels in (* Determine if there are "enough" new fields *) if 3 + 2 * List.length lbl_expr_list >= size @@ -989,12 +992,12 @@ if mut = Mutable then raise Not_constant; let cl = List.map extract_constant ll in match repres with - Record_regular -> Lconst(Const_block(0, cl)) + Record_regular -> Lconst(Const_block(record_tag, cl)) | Record_float -> Lconst(Const_float_array(List.map extract_float cl)) with Not_constant -> match repres with - Record_regular -> Lprim(Pmakeblock(0, mut), ll) + Record_regular -> Lprim(Pmakeblock(record_tag, mut), ll) | Record_float -> Lprim(Pmakearray Pfloatarray, ll) in begin match opt_init_expr with None -> lam diff -ru ocaml-4.00.0.orig/bytecomp/translmod.ml ocaml-4.00.0/bytecomp/translmod.ml --- ocaml-4.00.0.orig/bytecomp/translmod.ml 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/bytecomp/translmod.ml 2012-09-24 15:57:37.000000000 +0200 @@ -40,7 +40,7 @@ arg | Tcoerce_structure pos_cc_list -> name_lambda arg (fun id -> - Lprim(Pmakeblock(0, Immutable), + Lprim(Pmakeblock(Obj.module_tag, Immutable), List.map (apply_coercion_field id) pos_cc_list)) | Tcoerce_functor(cc_arg, cc_res) -> let param = Ident.create "funarg" in @@ -271,11 +271,11 @@ [] -> begin match cc with Tcoerce_none -> - Lprim(Pmakeblock(0, Immutable), + Lprim(Pmakeblock(Obj.module_tag, Immutable), List.map (fun id -> Lvar id) (List.rev fields)) | Tcoerce_structure pos_cc_list -> let v = Array.of_list (List.rev fields) in - Lprim(Pmakeblock(0, Immutable), + Lprim(Pmakeblock(Obj.module_tag, Immutable), List.map (fun (pos, cc) -> match cc with @@ -551,6 +551,7 @@ let transl_store_gen module_name ({ str_items = str }, restr) topl = reset_labels (); primitive_declarations := []; + Typeopt.module_name := module_name; let module_id = Ident.create_persistent module_name in let (map, prims, size) = build_ident_map restr (defined_idents str) in let f = function @@ -688,7 +689,7 @@ pos_cc_list | _ -> assert false in - Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)]) + Lprim(Psetglobal target_name, [Lprim(Pmakeblock(Obj.module_tag, Immutable), components)]) let transl_store_package component_names target_name coercion = let rec make_sequence fn pos arg = diff -ru ocaml-4.00.0.orig/bytecomp/typeopt.ml ocaml-4.00.0/bytecomp/typeopt.ml --- ocaml-4.00.0.orig/bytecomp/typeopt.ml 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/bytecomp/typeopt.ml 2012-09-24 15:57:37.000000000 +0200 @@ -128,3 +128,524 @@ bigarray_decode_type exp.exp_env layout_type layout_table Pbigarray_unknown_layout) | _ -> (Pbigarray_unknown, Pbigarray_unknown_layout) + + + + + + + + + + + + +open Predef + +let module_name = ref "" + +let max_level = 6 + +type block_repr = { + repr_tag : int option; + repr_size : int option; + repr_content : type_repr list option; + repr_labels : string list option; + } + +and type_repr = +| Repr_variable of int +| Repr_unknown +| Repr_integer +| Repr_block of block_repr +| Repr_choice of (string * type_repr) list +| Repr_path of type_repr list * string + +and path_repr = { + repr_path : string; + mutable repr_repr : type_repr; + mutable repr_level : int; + } + +type mem_repr = { + global_names : string array; + representations : (string, path_repr) Hashtbl.t; + } + +let (representations : (string, path_repr) Hashtbl.t) = Hashtbl.create 111 + +let find_representation path = + Hashtbl.find representations path + +let dummy_block = { + repr_tag = None; + repr_size = None; + repr_content = None; + repr_labels = None; + } + +let predef path r = { + repr_path = Path.name path; + repr_repr = r; + repr_level = max_level; + } + +let repr_list = + Repr_choice [ + "[]", Repr_integer; + "::", Repr_block + { + repr_labels = None; + repr_content = Some [ + Repr_variable 1; + Repr_path ([Repr_variable 1], Path.name path_list); + ]; + repr_tag = Some 222; + repr_size = Some 2 }; + "::", Repr_block + { + repr_labels = None; + repr_content = Some [ + Repr_variable 1; + Repr_path ([Repr_variable 1], Path.name path_list); + ]; + repr_tag = Some 0; + repr_size = Some 2 }; + ] + +let predef_reprs = [ + predef path_int Repr_integer; + predef path_char Repr_integer; + predef path_string (Repr_block + { dummy_block with repr_tag = Some Obj.string_tag }); + predef path_float (Repr_block + { dummy_block with repr_tag = Some Obj.double_tag }); + predef path_bool Repr_integer; + predef path_unit Repr_integer; + predef path_exn (Repr_block dummy_block); + predef path_array (Repr_block dummy_block); + predef path_format6 Repr_unknown; + predef path_option (Repr_choice [ + "None", Repr_integer; + "Some", Repr_block + { dummy_block with + repr_tag = Some 204; + repr_size = Some 1; + repr_content = Some [ Repr_variable 1 ]; + }; + "Some", Repr_block + { dummy_block with + repr_tag = Some 0; + repr_size = Some 1; + repr_content = Some [ Repr_variable 1 ]; + }; + ]); + predef path_list repr_list; + predef path_nativeint Repr_unknown; + predef path_int32 (Repr_block + { dummy_block with repr_tag = Some Obj.custom_tag }); + predef path_int64 (Repr_block + { dummy_block with repr_tag = Some Obj.custom_tag }); + predef path_lazy_t Repr_unknown; + ] + +let rec global = function + Pident id -> Ident.global id + | Pdot(p, s, pos) -> global p + | Papply(p1, p2) -> false + +let fix_path env path = + if not (global path) && not (Hashtbl.mem representations (Path.name path)) + then +(* +Printf.printf "%s is not a global name. Sub-module: " (Path.name path); +List.iter (fun n -> Printf.printf "%s " n) (Env.sub_module env); +print_newline (); +*) + + let module_id = Ident.create_persistent !module_name in + +(* + let rec iter list path = + match list with + [] -> path + | name :: tail -> + let path = iter tail path in + Pdot(path, name, -1) + in + let root_path = iter (Env.sub_module env) (Pident module_id) in +*) + + let root_path = (Env.sub_module env) in + let rec iter name path = + match path with + [] -> name + | p :: tail -> iter (Printf.sprintf "%s.%s" p name) tail + in + +(* + let rec iter p1 root_path = + match p1 with + Pident p -> Pdot(root_path, Ident.name p, -1) + | Pdot (p, name, _) -> + Pdot(iter p root_path, name, -1) + | Papply _ -> assert false (* Don't know what to do ! *) + in *) + let path = iter (Path.name path) root_path in + let path = Printf.sprintf "%s.%s" (Ident.name module_id) path in + (*Printf.printf "Bad path: %s" path; print_newline (); *) + path + else + ( (*Printf.printf "Good path: %s" (Path.name path); print_newline (); *) + Path.name path) + +let rec compute_type_repr vars level env ty = + if level > 0 then +(* let ty = Btype.repr ty in *) + let ty = Ctype.expand_head env ty in + match ty.desc with + | Tnil -> assert false + | Tfield _ -> assert false + | Tlink _ -> assert false + + | Tvariant _ + | Tobject _ + | Tunivar + | Tpoly _ + | Tsubst _ + | Tvar -> (try + Repr_variable (List.assq ty vars) + with _ -> Repr_unknown) + | Tarrow _ -> + Repr_block { dummy_block with + repr_tag = Some Obj.closure_tag; (* or Infix_tag ! *) + } + | Ttuple tyl -> + let args = List.map (compute_type_repr vars (level-1) env) tyl in + Repr_choice [ + "tagged_tuple", Repr_block { + repr_tag = Some Obj.tuple_tag; + repr_size = Some (List.length tyl); + repr_content = Some args; + repr_labels = None; + }; + "tuple", Repr_block { + repr_tag = Some 0; + repr_size = Some (List.length tyl); + repr_content = Some args; + repr_labels = None; + } + ] + | Tconstr (path, args , _) -> + let rr = + let path = fix_path env path in + try + find_representation path + with Not_found -> + let rr = { + repr_level = 0; + repr_repr = Repr_unknown; + repr_path = path; + } in + Hashtbl.add representations path rr; + rr + in + if rr.repr_level < level then begin + rr.repr_level <- level; + let repr = compute_path_repr level env path in + rr.repr_repr <- repr; + end; + Repr_path ( + List.map (fun ty -> + compute_type_repr vars level env ty + ) args, + rr.repr_path) + else + Repr_unknown + +and compute_path_repr level env path = + let decl = Env.find_type path env in + let vars = + let rec iter n tyl = + match tyl with + [] -> [] + | ty :: tail -> + match (Btype.repr ty).desc with + Tvar -> + (ty, n) :: (iter (n+1) tail) + | _ -> assert false + in + iter 1 decl.type_params + in + match decl with + { type_kind = Type_variant (cstrs, priv) } -> +(* Printf.printf "Should describe constructor %s" (Path.name path); +print_newline (); *) + + let num_consts = ref 0 and num_nonconsts = ref 0 in + List.iter + (function (name, []) -> incr num_consts + | (name, _) -> incr num_nonconsts) + cstrs; + let rec describe_constructors idx_nonconst = function + [] -> [] + | (name, []) :: rem -> + describe_constructors idx_nonconst rem + | (name, ty_args) :: rem -> + let (tag, descr_rem) = (idx_nonconst, + describe_constructors (idx_nonconst+1) rem) in + let args = List.map (compute_type_repr vars (level-1) env) ty_args in + if !num_nonconsts = 1 then + let tag = Datarepr.constructor_tag cstrs in + let cstr1 = + Repr_block { + repr_tag = Some tag; + repr_size = Some (List.length ty_args); + repr_content = Some args; + repr_labels = None; + } in + let cstr2 = + Repr_block { + repr_tag = Some 0; + repr_size = Some (List.length ty_args); + repr_content = Some args; + repr_labels = None; + } in + (name, cstr1) :: (name, cstr2) :: descr_rem + + else + let cstr = + Repr_block { + repr_tag = Some tag; + repr_size = Some (List.length ty_args); + repr_content = Some args; + repr_labels = None; + } in + (name, cstr) :: descr_rem + in + let choices = describe_constructors 0 + cstrs in + let choices = if !num_consts > 0 then + ("CONST", Repr_integer) :: choices else choices in + + (match choices with + [_, r] -> r + | _ -> Repr_choice choices) + | { type_kind = Type_record(lbls, rep, priv) } -> + + begin + match rep with + Record_float -> + Repr_block { dummy_block with + repr_tag = Some Obj.double_array_tag } + | Record_regular -> + + let tag = Datarepr.record_tag (List.map (fun (s,_,_) -> s) lbls) in + + let b = { + repr_tag = Some tag; + repr_size = Some (List.length lbls); + repr_content = Some (List.map (fun (_,_,ty) -> + compute_type_repr vars (level-1) env ty) lbls); + repr_labels = Some (List.map (fun (s,_,_) -> s) lbls); + } + in + Repr_choice [ + "tagged_record", Repr_block b; + "record", Repr_block { b with repr_tag = Some 0 }; + ] + + end + | { type_manifest = Some ty } -> + compute_type_repr vars level env ty + | _ -> + Repr_unknown + +let rec print_repr paths name level indent r = + Printf.printf "%s" indent; + if name <> "" then + Printf.printf "%s:" name; + match r with + Repr_variable i -> Printf.printf "|- '%d" i + | Repr_unknown -> Printf.printf "|- unknown" + | Repr_integer -> Printf.printf "|- int" + | Repr_path (args, path) -> + let s = (* Path.name *) path in +(* if s = "int" then begin + if rr.repr_path != Predef.path_int then + Printf.printf "NOT int !!!" + end; *) + Printf.printf "|- "; + (match args with + [] -> () + | list -> + Printf.printf "("; + List.iter (fun r -> + Printf.printf "["; + print_repr paths "" 1 (indent ^ " ") r; + Printf.printf "]"; + ) args; + Printf.printf ")"; + ); + Printf.printf " %s" s; + if level > 1 then begin + print_newline (); + try let rr = Hashtbl.find paths path in + print_repr paths "" (level-1) (indent ^ " ") rr.repr_repr + with _ -> Printf.printf "{%s}" ( (*Path.name*) path) + end else + Printf.printf "..." + + | Repr_choice list -> + Printf.printf "|----------------"; + if level > 1 then + List.iter (fun (name, r) -> + print_newline (); + print_repr paths "" (level-1) (indent ^ " ") r; + ) list + else + Printf.printf "..." + + | Repr_block rr -> + Printf.printf "|- block ("; + (match rr.repr_tag with None -> () | Some tag -> + Printf.printf "tag=%d, " tag); + (match rr.repr_size with None -> () | Some size -> + Printf.printf "size=%d, " size); + Printf.printf ")"; + if level > 1 then + (match rr.repr_content with + None -> () + | Some rs -> + match rr.repr_labels with + None -> + print_newline (); + List.iter (fun r -> + print_newline (); + print_repr paths "" (level-1) (indent ^ " ") r + ) rs + | Some labels -> + List.iter2 (fun name r -> + print_newline (); + print_repr paths name (level-1) (indent ^ " ") r + ) labels rs + ) else + Printf.printf "..." + + +let print_representation paths rr = + Printf.printf "Representation %s [%d] = " + ( (*Path.name*) rr.repr_path) rr.repr_level; + print_newline (); + print_repr paths "" max_level " " rr.repr_repr; + print_newline () + +let record_representation env ty = + if !module_name <> "" then +(* let ty = Btype.repr ty in *) + let ty = Ctype.expand_head env ty in + match ty.desc with + Tconstr (path, _, _) -> + + let rr = + let path = fix_path env path in + try find_representation path + with Not_found -> +(* Printf.printf "Not found"; print_newline (); *) + let rr = { + repr_path = path; + repr_repr = Repr_unknown; + repr_level = 0; + } in + Hashtbl.add representations path rr; + rr + in + if rr.repr_level < max_level then begin + rr.repr_level <- max_level; + rr.repr_repr <- compute_path_repr max_level env path; +(* print_representation representations rr; *) + end; + | _ -> assert false + +let _ = + List.iter (fun r -> + Hashtbl.add representations r.repr_path r + ) predef_reprs + + +let global_fields l = + let fv = ref [] in + let rec globfield = function + Lvar id -> () + | Lconst sc -> () + | Lapply(fn, args) -> + globfield fn; List.iter globfield args + | Lfunction(kind, params, body) -> + globfield body; + | Llet(str, id, arg, body) -> + globfield arg; globfield body; + | Lletrec(decl, body) -> + globfield body; + List.iter (fun (id, exp) -> globfield exp) decl + | Lprim(Psetfield(pos, _), + [Lprim (Pgetglobal id, []); Lvar id']) when Ident.global id -> +(* + Printf.printf "Psetfield %s at pos %d with %s" +(Ident.name id) pos (Ident.unique_name id'); print_newline (); + *) + fv := (pos,id') :: !fv + | Lprim(p, args) -> + List.iter globfield args + | Lswitch(arg, sw) -> + globfield arg; + List.iter (fun (key, case) -> globfield case) sw.sw_consts; + List.iter (fun (key, case) -> globfield case) sw.sw_blocks; + begin match sw.sw_failaction with + | None -> () + | Some l -> globfield l + end + | Lstaticraise (_,args) -> + List.iter globfield args + | Lstaticcatch(e1, (_,vars), e2) -> + globfield e1; globfield e2 + | Ltrywith(e1, exn, e2) -> + globfield e1; globfield e2 + | Lifthenelse(e1, e2, e3) -> + globfield e1; globfield e2; globfield e3 + | Lsequence(e1, e2) -> + globfield e1; globfield e2 + | Lwhile(e1, e2) -> + globfield e1; globfield e2 + | Lfor(v, e1, e2, dir, e3) -> + globfield e1; globfield e2; globfield e3 + | Lassign(id, e) -> + globfield e + | Lsend (k, met, obj, args) -> + List.iter globfield (met::obj::args) + | Levent (lam, evt) -> + globfield lam + | Lifused (v, e) -> + globfield e + in globfield l; !fv + +let extract_mem lam = + + let globals = global_fields lam in + let maxi = ref 0 in + (* + Hashtbl.iter (fun path r -> + print_representation representations r +) representations; + *) + List.iter (fun (pos, id) -> + if pos > !maxi then maxi := pos + ) globals; + let t = Array.create (!maxi + 1) "-" in + List.iter (fun (pos, id) -> + t.(pos) <- Ident.unique_name id + ) globals; + { + global_names = t; + representations = representations; + } + \ No newline at end of file diff -ru ocaml-4.00.0.orig/bytecomp/typeopt.mli ocaml-4.00.0/bytecomp/typeopt.mli --- ocaml-4.00.0.orig/bytecomp/typeopt.mli 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/bytecomp/typeopt.mli 2012-09-24 15:57:37.000000000 +0200 @@ -20,3 +20,39 @@ val array_pattern_kind : Typedtree.pattern -> Lambda.array_kind val bigarray_kind_and_layout : Typedtree.expression -> Lambda.bigarray_kind * Lambda.bigarray_layout + + +type block_repr = { + repr_tag : int option; + repr_size : int option; + repr_content : type_repr list option; + repr_labels : string list option; + } + +and type_repr = +| Repr_variable of int +| Repr_unknown +| Repr_integer +| Repr_block of block_repr +| Repr_choice of (string * type_repr) list +| Repr_path of type_repr list * string + +and path_repr = { + repr_path : string; + mutable repr_repr : type_repr; + mutable repr_level : int; + } + +type mem_repr = { + global_names : string array; + representations : (string, path_repr) Hashtbl.t; + } + +val module_name : string ref +val record_representation : Env.t -> Types.type_expr -> unit +val extract_mem : Lambda.lambda -> mem_repr +val print_representation : + (string, path_repr) Hashtbl.t -> path_repr -> unit + val print_repr : + (string, path_repr) Hashtbl.t -> + string -> int -> string -> type_repr -> unit diff -ru ocaml-4.00.0.orig/byterun/gc_ctrl.c ocaml-4.00.0/byterun/gc_ctrl.c --- ocaml-4.00.0.orig/byterun/gc_ctrl.c 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/byterun/gc_ctrl.c 2012-09-24 15:57:37.000000000 +0200 @@ -411,6 +411,13 @@ return Val_unit; } +CAMLprim value caml_dump_heap (value unit) +{ + caml_minor_collection(); + really_dump_heap(); + return Val_unit; +} + static void test_and_compact (void) { float fp; diff -ru ocaml-4.00.0.orig/byterun/major_gc.c ocaml-4.00.0/byterun/major_gc.c --- ocaml-4.00.0.orig/byterun/major_gc.c 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/byterun/major_gc.c 2012-09-24 16:14:22.000000000 +0200 @@ -29,6 +29,9 @@ #include "roots.h" #include "weak.h" +int heap_profiling = 0; +void really_dump_heap(); + uintnat caml_percent_free; uintnat caml_major_heap_increment; CAMLexport char *caml_heap_start; @@ -269,6 +272,7 @@ caml_gc_sweep_hp = caml_heap_start; caml_fl_init_merge (); caml_gc_phase = Phase_sweep; + if(heap_profiling) really_dump_heap(); chunk = caml_heap_start; caml_gc_sweep_hp = chunk; limit = chunk + Chunk_size (chunk); @@ -508,3 +512,238 @@ caml_allocated_words = 0; caml_extra_heap_resources = 0.0; } + +#include "intext.h" +#include "instruct.h" +#include + +#ifndef NATIVE_CODE +#include "stacks.h" +#endif + +#include +#include + +#define Next(hp) ((hp) + Bhsize_hp (hp)) + +static FILE *file_oc; + +static void store_value(value v) +{ + if(sizeof(value) == 4){ + fputc( (v & 0xff), file_oc); + fputc( ( (v >> 8) & 0xff), file_oc); + fputc( ( (v >> 16) & 0xff), file_oc); + fputc( ( (v >> 24) & 0xff), file_oc); + } else { + fputc( (v & 0xff), file_oc); + fputc( ( (v >> 8) & 0xff), file_oc); + fputc( ( (v >> 16) & 0xff), file_oc); + fputc( ( (v >> 24) & 0xff), file_oc); + fputc( ( (v >> 32) & 0xff), file_oc); + fputc( ( (v >> 40) & 0xff), file_oc); + fputc( ( (v >> 48) & 0xff), file_oc); + fputc( ( (v >> 56) & 0xff), file_oc); + } +} + +static void check_block (char *hp) +{ + mlsize_t nfields = Wosize_hp (hp); + mlsize_t i; + value v = Val_hp (hp); + value f; + mlsize_t lastbyte; + int tag = Tag_hp (hp); + + fputc(1, file_oc); /* 1, a block */ + store_value( v); /* the pointer */ + fputc(tag, file_oc); /* the tag */ + store_value( nfields); /* the size */ + + /* if tag < No_scan_tag only, the contents of the block */ + switch(tag){ + case String_tag: + case Double_tag: + case Double_array_tag: + case Custom_tag: break; + + default: + if(Tag_hp (hp) < No_scan_tag){ + for (i = 0; i < Wosize_hp (hp); i++){ + f = Field (v, i); +#ifndef NATIVE_CODE + if ((char *) f >= caml_code_area_start && (char *) f < caml_code_area_end) { +#ifdef THREADED_CODE + if ( *(code_t)f == (opcode_t)(caml_instr_table[RESTART] - caml_instr_base) ){ +#else + if ( *(code_t)f == RESTART ){ +#endif + store_value( (value)caml_code_area_end); + } else { + store_value( (value)caml_code_area_start); + } + } else +#endif + { + store_value( f); + } +/* + if (Is_block (f) && Is_in_heap (f)) { + fprintf( " %x", f); + } +*/ + } + } + } +} + +void store_root(value v, value *useless) +{ + if(Is_block(v) && Is_in_heap(v)) store_value(v); +} + +extern char *caml_exe_name; + +#ifdef NATIVE_CODE +extern char caml_globals_map[]; +extern value caml_globals[]; +extern value caml_globals_info[]; +#endif + +static int heap_number = 0; +void really_dump_heap (void) +{ + char *chunk = caml_heap_start, *chunk_end; + char *cur_hp, *prev_hp; + header_t cur_hd; + char filename[256]; + sprintf(filename, "heap.dump.%d.%d", getpid(), heap_number++); + + file_oc = fopen(filename, "w"); + + fputc(sizeof(value), file_oc); + +{ + int size = strlen(caml_exe_name); + store_value( size); + fwrite(caml_exe_name, 1, size, file_oc); +} + + while (chunk != NULL){ + chunk_end = chunk + Chunk_size (chunk); + + fputc(0, file_oc); /* 0: a chunk */ + store_value( (value) chunk); /* chunk start */ + store_value( (value) chunk_end); /* chunk end */ + + prev_hp = NULL; + cur_hp = chunk; + while (cur_hp < chunk_end){ + cur_hd = Hd_hp (cur_hp); + Assert (Next (cur_hp) <= chunk_end); + switch (Color_hd (cur_hd)){ + case Caml_white: + if ((Wosize_hd (cur_hd) == 0) + || (caml_gc_phase == Phase_sweep && cur_hp >= caml_gc_sweep_hp)){ + /* free block */ + }else{ + check_block ( cur_hp); + } + break; + case Caml_gray: case Caml_black: + check_block ( cur_hp); + break; + case Caml_blue: + /* free block */ + break; + } + prev_hp = cur_hp; + cur_hp = Next (cur_hp); + } Assert (cur_hp == chunk_end); + chunk = Chunk_next (chunk); + } + fputc(255, file_oc); /* 255: end of the file */ + +/* All CLOSURE Codepointers have this value */ + store_value( (value)caml_code_area_start); +/* All RESTART Codepointers have this value */ + store_value( (value)caml_code_area_end); + +#ifdef NATIVE_CODE + store_value( 0); /* We are in native code */ + +/* We need to store the globals_map */ +{ + value* s = caml_globals_map; + int len = caml_string_length(s); + + store_value( len ); + fwrite(s, 1, len, file_oc); +} + +/* We need to store the caml_globals, and their corresponding pointers */ +{ + value* s = caml_globals; + int pos = 0; + while(s[pos] != 0) { + value m = s[pos]; + pos++; + + if(!(Is_block(m))){ + store_value(1); /* Another module */ + store_value(0); + } else { + int size = Wosize_val(m); + int i; + + store_value(1); /* Another module */ + store_value(m); + store_value(size); + for(i=0; i .depend diff -ru ocaml-4.00.0.orig/ocamldoc/odoc_ast.ml ocaml-4.00.0/ocamldoc/odoc_ast.ml --- ocaml-4.00.0.orig/ocamldoc/odoc_ast.ml 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/ocamldoc/odoc_ast.ml 2012-09-24 16:17:14.000000000 +0200 @@ -333,7 +333,6 @@ in (new_param, func_body2) | _ -> - print_DEBUG3 "Pas le bon filtre pour le parametre optionnel avec valeur par defaut."; (parameter, func_body) ) ) @@ -492,7 +491,6 @@ in (new_param, body2) | _ -> - print_DEBUG3 "Pas le bon filtre pour le parametre optionnel avec valeur par defaut."; (parameter, body) ) ) diff -ru ocaml-4.00.0.orig/ocamldoc/odoc.ml ocaml-4.00.0/ocamldoc/odoc.ml --- ocaml-4.00.0.orig/ocamldoc/odoc.ml 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/ocamldoc/odoc.ml 2012-09-24 16:16:14.000000000 +0200 @@ -83,7 +83,6 @@ ;; List.iter load_plugin plugins;; -let () = print_DEBUG "Fin du chargement dynamique eventuel" let () = Odoc_args.parse () Only in ocaml-4.00.0: README.memprof diff -ru ocaml-4.00.0.orig/stdlib/gc.ml ocaml-4.00.0/stdlib/gc.ml --- ocaml-4.00.0.orig/stdlib/gc.ml 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/stdlib/gc.ml 2012-09-24 15:57:43.000000000 +0200 @@ -100,3 +100,5 @@ ;; let delete_alarm a = a := false;; + +external dump_heap : unit -> unit = "caml_dump_heap" \ No newline at end of file diff -ru ocaml-4.00.0.orig/stdlib/gc.mli ocaml-4.00.0/stdlib/gc.mli --- ocaml-4.00.0.orig/stdlib/gc.mli 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/stdlib/gc.mli 2012-09-24 15:57:43.000000000 +0200 @@ -272,3 +272,7 @@ val delete_alarm : alarm -> unit (** [delete_alarm a] will stop the calls to the function associated to [a]. Calling [delete_alarm a] again has no effect. *) + +external dump_heap : unit -> unit = "caml_dump_heap" + + \ No newline at end of file diff -ru ocaml-4.00.0.orig/stdlib/obj.ml ocaml-4.00.0/stdlib/obj.ml --- ocaml-4.00.0.orig/stdlib/obj.ml 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/stdlib/obj.ml 2012-09-24 15:57:43.000000000 +0200 @@ -39,6 +39,17 @@ let unmarshal str pos = (Marshal.from_string str pos, pos + Marshal.total_size str pos) + +let min_constructor_tag = 200 +let nb_constructor_tags = 40 +let min_record_tag = 100 +let nb_record_tags = 100 +let tuple_tag = 241 +let option_tag = 242 +let array_tag = 243 +let list_tag = 244 +let module_tag = 245 + let lazy_tag = 246 let closure_tag = 247 let object_tag = 248 diff -ru ocaml-4.00.0.orig/stdlib/obj.mli ocaml-4.00.0/stdlib/obj.mli --- ocaml-4.00.0.orig/stdlib/obj.mli 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/stdlib/obj.mli 2012-09-24 15:57:43.000000000 +0200 @@ -38,6 +38,16 @@ external add_offset : t -> Int32.t -> t = "caml_obj_add_offset" (* @since 3.12.0 *) +val min_record_tag : int +val nb_record_tags : int +val min_constructor_tag : int +val nb_constructor_tags : int +val tuple_tag : int +val option_tag : int +val array_tag : int +val list_tag : int +val module_tag : int + val lazy_tag : int val closure_tag : int val object_tag : int diff -ru ocaml-4.00.0.orig/typing/datarepr.ml ocaml-4.00.0/typing/datarepr.ml --- ocaml-4.00.0.orig/typing/datarepr.ml 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/typing/datarepr.ml 2012-09-24 16:08:11.000000000 +0200 @@ -42,6 +42,12 @@ unmark_type ty; !ret +let constructor_tag list = + let name = ref "" in + List.iter (fun (n,_) -> name := !name ^ n) list; + (Hashtbl.hash_param 10 100 !name) mod Obj.nb_constructor_tags + + Obj.min_constructor_tag + let constructor_descrs ty_res cstrs priv = let num_consts = ref 0 and num_nonconsts = ref 0 and num_normal = ref 0 in List.iter @@ -77,6 +83,8 @@ cstr_args = ty_args; cstr_arity = List.length ty_args; cstr_tag = tag; + cstr_alloc_tag = + (if !num_nonconsts = 1 then constructor_tag cstrs else idx_nonconst); cstr_consts = !num_consts; cstr_nonconsts = !num_nonconsts; cstr_normal = !num_normal; @@ -92,6 +100,7 @@ cstr_args = decl.exn_args; cstr_arity = List.length decl.exn_args; cstr_tag = Cstr_exception (path_exc, decl.exn_loc); + cstr_alloc_tag = 0; cstr_consts = -1; cstr_nonconsts = -1; cstr_private = Public; @@ -103,10 +112,23 @@ let dummy_label = { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable; lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular; - lbl_private = Public } + lbl_private = Public; lbl_tag = Obj.min_record_tag; } + +let record_tag list = + let name = ref "" in + List.iter (fun n -> name := !name ^ n) list; + (Hashtbl.hash_param 10 100 !name) mod Obj.nb_record_tags + Obj.min_record_tag + +(* let record_tags = ref [] *) + -let label_descrs ty_res lbls repres priv = +let label_descrs ty_path ty_res lbls repres priv = let all_labels = Array.create (List.length lbls) dummy_label in + let tag = record_tag (List.map (fun (s,_,_) -> s) lbls) in + let _ (* ty_path *) = Path.name ty_path in +(* + if not (List.mem (ty_path, tag) !record_tags) then + record_tags := (ty_path, tag) :: !record_tags; *) let rec describe_labels num = function [] -> [] | (name, mut_flag, ty_arg) :: rest -> @@ -117,6 +139,7 @@ lbl_mut = mut_flag; lbl_pos = num; lbl_all = all_labels; + lbl_tag = tag; lbl_repres = repres; lbl_private = priv } in all_labels.(num) <- lbl; diff -ru ocaml-4.00.0.orig/typing/datarepr.mli ocaml-4.00.0/typing/datarepr.mli --- ocaml-4.00.0.orig/typing/datarepr.mli 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/typing/datarepr.mli 2012-09-24 16:07:32.000000000 +0200 @@ -24,7 +24,7 @@ val exception_descr: Path.t -> exception_declaration -> constructor_description val label_descrs: - type_expr -> (Ident.t * mutable_flag * type_expr) list -> + Path.t -> type_expr -> (Ident.t * mutable_flag * type_expr) list -> record_representation -> private_flag -> (Ident.t * label_description) list @@ -33,3 +33,6 @@ val find_constr_by_tag: constructor_tag -> (Ident.t * type_expr list * type_expr option) list -> Ident.t * type_expr list * type_expr option + +val record_tag : string list -> int +val constructor_tag : (string * 'a) list -> int diff -ru ocaml-4.00.0.orig/typing/env.ml ocaml-4.00.0/typing/env.ml --- ocaml-4.00.0.orig/typing/env.ml 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/typing/env.ml 2012-09-24 16:09:55.000000000 +0200 @@ -153,6 +153,7 @@ components: (Path.t * module_components) EnvTbl.t; classes: (Path.t * class_declaration) EnvTbl.t; cltypes: (Path.t * class_type_declaration) EnvTbl.t; + path: string list; summary: summary; local_constraints: bool; gadt_instances: (int * TypeSet.t ref) list; @@ -199,7 +200,7 @@ constrs_by_path = EnvTbl.empty; modules = EnvTbl.empty; modtypes = EnvTbl.empty; components = EnvTbl.empty; classes = EnvTbl.empty; - cltypes = EnvTbl.empty; + cltypes = EnvTbl.empty; path = []; summary = Env_empty; local_constraints = false; gadt_instances = []; in_signature = false; } @@ -744,7 +745,7 @@ let labels_of_type ty_path decl = match decl.type_kind with Type_record(labels, rep) -> - Datarepr.label_descrs + Datarepr.label_descrs ty_path (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) labels rep decl.type_private | Type_variant _ | Type_abstract -> [] @@ -1221,6 +1222,11 @@ remove_file filename; raise exn +let enter_sub_module env m = + { env with path = m :: env.path } + +let sub_module env = env.path + let save_signature sg modname filename = save_signature_with_imports sg modname filename (imported_units()) diff -ru ocaml-4.00.0.orig/typing/env.mli ocaml-4.00.0/typing/env.mli --- ocaml-4.00.0.orig/typing/env.mli 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/typing/env.mli 2012-09-24 15:57:43.000000000 +0200 @@ -219,3 +219,5 @@ +val enter_sub_module : t -> string -> t +val sub_module : t -> string list \ No newline at end of file diff -ru ocaml-4.00.0.orig/typing/typemod.ml ocaml-4.00.0/typing/typemod.ml --- ocaml-4.00.0.orig/typing/typemod.ml 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/typing/typemod.ml 2012-09-24 16:12:33.000000000 +0200 @@ -991,8 +991,8 @@ | Pstr_module(name, smodl) -> check "module" loc module_names name.txt; let modl = - type_module true funct_body (anchor_submodule name.txt anchor) env - smodl in + type_module true funct_body (anchor_submodule name.txt anchor) + (Env.enter_sub_module env name) smodl in let mty = enrich_module_type anchor name.txt modl.mod_type env in let (id, newenv) = Env.enter_module name.txt mty env in let (str_rem, sig_rem, final_env) = type_struct newenv srem in diff -ru ocaml-4.00.0.orig/typing/types.ml ocaml-4.00.0/typing/types.ml --- ocaml-4.00.0.orig/typing/types.ml 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/typing/types.ml 2012-09-24 15:57:43.000000000 +0200 @@ -112,6 +112,7 @@ cstr_args: type_expr list; (* Type of the arguments *) cstr_arity: int; (* Number of arguments *) cstr_tag: constructor_tag; (* Tag for heap blocks *) + cstr_alloc_tag: int; (* Tag for heap blocks *) cstr_consts: int; (* Number of constant constructors *) cstr_nonconsts: int; (* Number of non-const constructors *) cstr_normal: int; (* Number of non generalized constrs *) @@ -131,6 +132,7 @@ lbl_arg: type_expr; (* Type of the argument *) lbl_mut: mutable_flag; (* Is this a mutable field? *) lbl_pos: int; (* Position in block *) + lbl_tag : int; lbl_all: label_description array; (* All the labels in this type *) lbl_repres: record_representation; (* Representation for this record *) lbl_private: private_flag } (* Read-only field? *) diff -ru ocaml-4.00.0.orig/typing/types.mli ocaml-4.00.0/typing/types.mli --- ocaml-4.00.0.orig/typing/types.mli 2012-09-24 15:57:14.000000000 +0200 +++ ocaml-4.00.0/typing/types.mli 2012-09-24 16:13:05.000000000 +0200 @@ -109,6 +109,7 @@ cstr_args: type_expr list; (* Type of the arguments *) cstr_arity: int; (* Number of arguments *) cstr_tag: constructor_tag; (* Tag for heap blocks *) + cstr_alloc_tag: int; (* Tag for heap blocks *) cstr_consts: int; (* Number of constant constructors *) cstr_nonconsts: int; (* Number of non-const constructors *) cstr_normal: int; (* Number of non generalized constrs *) @@ -128,6 +129,7 @@ lbl_arg: type_expr; (* Type of the argument *) lbl_mut: mutable_flag; (* Is this a mutable field? *) lbl_pos: int; (* Position in block *) + lbl_tag : int; lbl_all: label_description array; (* All the labels in this type *) lbl_repres: record_representation; (* Representation for this record *) lbl_private: private_flag } (* Read-only field? *)