diff -ruN ocaml-3.10.0.old/asmcomp/asmlink.ml ocaml-3.10.0/asmcomp/asmlink.ml --- ocaml-3.10.0.old/asmcomp/asmlink.ml 2007-11-13 00:14:58.000000000 +0000 +++ ocaml-3.10.0/asmcomp/asmlink.ml 2007-11-13 00:15:24.000000000 +0000 @@ -208,6 +208,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 -ruN ocaml-3.10.0.old/asmcomp/closure.ml ocaml-3.10.0/asmcomp/closure.ml --- ocaml-3.10.0.old/asmcomp/closure.ml 2007-11-13 00:14:58.000000000 +0000 +++ ocaml-3.10.0/asmcomp/closure.ml 2007-11-13 00:15:24.000000000 +0000 @@ -794,10 +794,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 -ruN ocaml-3.10.0.old/asmcomp/closure.mli ocaml-3.10.0/asmcomp/closure.mli --- ocaml-3.10.0.old/asmcomp/closure.mli 2007-11-13 00:14:58.000000000 +0000 +++ ocaml-3.10.0/asmcomp/closure.mli 2007-11-13 00:15:24.000000000 +0000 @@ -14,5 +14,5 @@ (* 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 -ruN ocaml-3.10.0.old/asmcomp/cmmgen.ml ocaml-3.10.0/asmcomp/cmmgen.ml --- ocaml-3.10.0.old/asmcomp/cmmgen.ml 2007-11-13 00:14:58.000000000 +0000 +++ ocaml-3.10.0/asmcomp/cmmgen.ml 2007-11-13 00:15:24.000000000 +0000 @@ -1704,7 +1704,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"); @@ -1712,10 +1712,16 @@ fun_body = init_code; fun_fast = false}] 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) @@ -1961,6 +1967,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 globals_map namelist = Cdata(Cglobal_symbol "caml_globals_map" :: emit_constant "caml_globals_map" diff -ruN ocaml-3.10.0.old/asmcomp/cmmgen.mli ocaml-3.10.0/asmcomp/cmmgen.mli --- ocaml-3.10.0.old/asmcomp/cmmgen.mli 2007-11-13 00:14:58.000000000 +0000 +++ ocaml-3.10.0/asmcomp/cmmgen.mli 2007-11-13 00:15:24.000000000 +0000 @@ -14,13 +14,14 @@ (* 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 val curry_function: int -> 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 globals_map: (string * string) list -> Cmm.phrase val frame_table: string list -> Cmm.phrase val data_segment_table: string list -> Cmm.phrase diff -ruN ocaml-3.10.0.old/asmrun/Makefile ocaml-3.10.0/asmrun/Makefile --- ocaml-3.10.0.old/asmrun/Makefile 2007-11-13 00:14:58.000000000 +0000 +++ ocaml-3.10.0/asmrun/Makefile 2007-11-13 00:15:24.000000000 +0000 @@ -18,7 +18,7 @@ CC=$(NATIVECC) FLAGS=-I../byterun -DCAML_NAME_SPACE -DNATIVE_CODE \ -DTARGET_$(ARCH) -DSYS_$(SYSTEM) -CFLAGS=$(FLAGS) -O $(NATIVECCCOMPOPTS) +CFLAGS=$(FLAGS) -g -O $(NATIVECCCOMPOPTS) DFLAGS=$(FLAGS) -g -DDEBUG $(NATIVECCCOMPOPTS) PFLAGS=$(FLAGS) -pg -O -DPROFILING $(NATIVECCPROFOPTS) diff -ruN ocaml-3.10.0.old/asmrun/startup.c ocaml-3.10.0/asmrun/startup.c --- ocaml-3.10.0.old/asmrun/startup.c 2007-11-13 00:14:58.000000000 +0000 +++ ocaml-3.10.0/asmrun/startup.c 2007-11-13 00:15:24.000000000 +0000 @@ -95,6 +95,7 @@ } } +extern int heap_profiling; static void parse_camlrunparam(void) { char *opt = getenv ("OCAMLRUNPARAM"); @@ -113,6 +114,7 @@ case 'v': scanmult (opt, &caml_verb_gc); break; case 'b': caml_init_backtrace(); break; case 'p': caml_parser_trace = 1; break; + case 'm': heap_profiling = 1; break; } } } diff -ruN ocaml-3.10.0.old/boot/camlheader ocaml-3.10.0/boot/camlheader --- ocaml-3.10.0.old/boot/camlheader 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/boot/camlheader 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1 @@ +#!/usr/local/bin/ocamlrun diff -ruN ocaml-3.10.0.old/bytecomp/translcore.ml ocaml-3.10.0/bytecomp/translcore.ml --- ocaml-3.10.0.old/bytecomp/translcore.ml 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/bytecomp/translcore.ml 2007-11-13 00:16:08.000000000 +0000 @@ -618,10 +618,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) @@ -640,7 +641,12 @@ [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) -> @@ -857,7 +863,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 @@ -890,12 +896,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 -ruN ocaml-3.10.0.old/bytecomp/translmod.ml ocaml-3.10.0/bytecomp/translmod.ml --- ocaml-3.10.0.old/bytecomp/translmod.ml 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/bytecomp/translmod.ml 2007-11-13 00:15:24.000000000 +0000 @@ -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 @@ -266,11 +266,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 @@ -531,6 +531,7 @@ let transl_store_implementation module_name (str, restr) = 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 transl_store_label_init module_id size @@ -649,7 +650,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 -ruN ocaml-3.10.0.old/bytecomp/typeopt.ml ocaml-3.10.0/bytecomp/typeopt.ml --- ocaml-3.10.0.old/bytecomp/typeopt.ml 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/bytecomp/typeopt.ml 2007-11-13 00:15:24.000000000 +0000 @@ -132,3 +132,524 @@ bigarray_decode_type 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 -ruN ocaml-3.10.0.old/bytecomp/typeopt.mli ocaml-3.10.0/bytecomp/typeopt.mli --- ocaml-3.10.0.old/bytecomp/typeopt.mli 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/bytecomp/typeopt.mli 2007-11-13 00:15:24.000000000 +0000 @@ -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 -ruN ocaml-3.10.0.old/byterun/gc_ctrl.c ocaml-3.10.0/byterun/gc_ctrl.c --- ocaml-3.10.0.old/byterun/gc_ctrl.c 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/byterun/gc_ctrl.c 2007-11-13 00:15:24.000000000 +0000 @@ -392,6 +392,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 -ruN ocaml-3.10.0.old/byterun/major_gc.c ocaml-3.10.0/byterun/major_gc.c --- ocaml-3.10.0.old/byterun/major_gc.c 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/byterun/major_gc.c 2007-11-13 00:15:24.000000000 +0000 @@ -29,6 +29,9 @@ #include "roots.h" #include "weak.h" +int heap_profiling = 0; +void really_dump_heap(); + uintnat caml_percent_free; intnat caml_major_heap_increment; CAMLexport char *caml_heap_start, *caml_heap_end; @@ -246,6 +249,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); @@ -485,3 +489,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 +#include "Main.h" +#include "Defines.h" +#include "Error.h" +#include "HpFile.h" +#include "Utilities.h" + +/* own stuff */ +#include "AreaBelow.h" + +extern void free(); + +/* + * Return the area enclosed by all of the curves. The algorithm + * used is the same as the trapizoidal rule for integration. + */ + +floatish +AreaBelow() +{ + intish i; + intish j; + intish bucket; + floatish value; + struct chunk *ch; + floatish area; + floatish trap; + floatish base; + floatish *maxima; + + maxima = (floatish *) xmalloc(nsamples * sizeof(floatish)); + for (i = 0; i < nsamples; i++) { + maxima[i] = 0.0; + } + + for (i = 0; i < nidents; i++) { + for (ch = identtable[i]->chk; ch; ch = ch->next) { + for (j = 0; j < ch->nd; j++) { + bucket = ch->d[j].bucket; + value = ch->d[j].value; + if (bucket >= nsamples) + Disaster("bucket out of range"); + maxima[ bucket ] += value; + } + } + } + + area = 0.0; + + for (i = 1; i < nsamples; i++) { + base = samplemap[i] - samplemap[i-1]; + if (maxima[i] > maxima[i-1]) { + trap = base * maxima[i-1] + ((base * (maxima[i] - maxima[i-1]))/ 2.0); + } else { + trap = base * maxima[i] + ((base * (maxima[i-1] - maxima[i]))/ 2.0); + } + + area += trap; + } + + free(maxima); + return area; +} diff -ruN ocaml-3.10.0.old/hp/hp2ps/AreaBelow.h ocaml-3.10.0/hp/hp2ps/AreaBelow.h --- ocaml-3.10.0.old/hp/hp2ps/AreaBelow.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/AreaBelow.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,6 @@ +#ifndef AREA_BELOW_H +#define AREA_BELOW_H + +floatish AreaBelow PROTO((void)); + +#endif /* AREA_BELOW_H */ diff -ruN ocaml-3.10.0.old/hp/hp2ps/AuxFile.c ocaml-3.10.0/hp/hp2ps/AuxFile.c --- ocaml-3.10.0.old/hp/hp2ps/AuxFile.c 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/AuxFile.c 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,168 @@ +#include +#include +#include +#include "Main.h" +#include "Defines.h" +#include "Shade.h" +#include "Error.h" +#include "HpFile.h" +#include "Reorder.h" + +/* own stuff */ +#include "AuxFile.h" + +static void GetAuxLine PROTO((FILE *)); /* forward */ +static void GetAuxTok PROTO((FILE *)); /* forward */ + +void +GetAuxFile(auxfp) + FILE* auxfp; +{ + ch = ' '; + endfile = 0; + linenum = 1; + + GetAuxTok(auxfp); + + while (endfile == 0) { + GetAuxLine(auxfp); + } + + fclose(auxfp); +} + + + +/* + * Read the next line from the aux file, check the syntax, and + * perform the appropriate action. + */ + +static void +GetAuxLine(auxfp) + FILE* auxfp; +{ + switch (thetok) { + case X_RANGE_TOK: + GetAuxTok(auxfp); + if (thetok != FLOAT_TOK) { + Error("%s, line %d, floating point number must follow X_RANGE", + auxfile, linenum); + } + auxxrange = thefloatish; + GetAuxTok(auxfp); + break; + case Y_RANGE_TOK: + GetAuxTok(auxfp); + if (thetok != FLOAT_TOK) { + Error("%s, line %d, floating point number must follow Y_RANGE", + auxfile, linenum); + } + auxyrange = thefloatish; + GetAuxTok(auxfp); + break; + case ORDER_TOK: + GetAuxTok(auxfp); + if (thetok != IDENTIFIER_TOK) { + Error("%s, line %d: identifier must follow ORDER", + auxfile, linenum); + } + GetAuxTok(auxfp); + if (thetok != INTEGER_TOK) { + Error("%s, line %d: identifier and integer must follow ORDER", + auxfile, linenum); + } + OrderFor(theident, theinteger); + GetAuxTok(auxfp); + break; + case SHADE_TOK: + GetAuxTok(auxfp); + if (thetok != IDENTIFIER_TOK) { + Error("%s, line %d: identifier must follow SHADE", + auxfile, linenum); + } + GetAuxTok(auxfp); + if (thetok != FLOAT_TOK) { + Error("%s, line %d: identifier and floating point number must follow SHADE", + auxfile, linenum); + } + ShadeFor(theident, thefloatish); + GetAuxTok(auxfp); + break; + case EOF_TOK: + endfile = 1; + break; + default: + Error("%s, line %d: %s unexpected", auxfile, linenum, + TokenToString(thetok)); + break; + } +} + + + +/* + * Read the next token from the input and assign its value + * to the global variable "thetok". In the case of numbers, + * the corresponding value is also assigned to "thefloatish"; + * in the case of identifiers it is assigned to "theident". + */ + +static void GetAuxTok(auxfp) +FILE* auxfp; +{ + + while (isspace(ch)) { /* skip whitespace */ + if (ch == '\n') linenum++; + ch = getc(auxfp); + } + + if (ch == EOF) { + thetok = EOF_TOK; + return; + } + + if (isdigit(ch)) { + thetok = GetNumber(auxfp); + return; + } else if (IsIdChar(ch)) { /* ch can't be a digit here */ + GetIdent(auxfp); + if (!isupper(theident[0])) { + thetok = IDENTIFIER_TOK; + } else if (strcmp(theident, "X_RANGE") == 0) { + thetok = X_RANGE_TOK; + } else if (strcmp(theident, "Y_RANGE") == 0) { + thetok = Y_RANGE_TOK; + } else if (strcmp(theident, "ORDER") == 0) { + thetok = ORDER_TOK; + } else if (strcmp(theident, "SHADE") == 0) { + thetok = SHADE_TOK; + } else { + thetok = IDENTIFIER_TOK; + } + return; + } else { + Error("%s, line %d: strange character (%c)", auxfile, linenum, ch); + } +} + +void +PutAuxFile(auxfp) + FILE* auxfp; +{ + int i; + + fprintf(auxfp, "X_RANGE %.2f\n", xrange); + fprintf(auxfp, "Y_RANGE %.2f\n", yrange); + + for (i = 0; i < nidents; i++) { + fprintf(auxfp, "ORDER %s %d\n", identtable[i]->name, i+1); + } + + for (i = 0; i < nidents; i++) { + fprintf(auxfp, "SHADE %s %.2f\n", identtable[i]->name, + ShadeOf(identtable[i]->name)); + } + + fclose(auxfp); +} diff -ruN ocaml-3.10.0.old/hp/hp2ps/AuxFile.h ocaml-3.10.0/hp/hp2ps/AuxFile.h --- ocaml-3.10.0.old/hp/hp2ps/AuxFile.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/AuxFile.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,7 @@ +#ifndef AUX_FILE_H +#define AUX_FILE_H + +void PutAuxFile PROTO((FILE *)); +void GetAuxFile PROTO((FILE *)); + +#endif /* AUX_FILE_H */ diff -ruN ocaml-3.10.0.old/hp/hp2ps/Axes.c ocaml-3.10.0/hp/hp2ps/Axes.c --- ocaml-3.10.0.old/hp/hp2ps/Axes.c 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Axes.c 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,241 @@ +#include +#include +#include "Main.h" +#include "Curves.h" +#include "Defines.h" +#include "Dimensions.h" +#include "HpFile.h" +#include "Utilities.h" + +/* own stuff */ +#include "Axes.h" + +typedef enum {MEGABYTE, KILOBYTE, BYTE} mkb; + +static void XAxis PROTO((void)); /* forward */ +static void YAxis PROTO((void)); /* forward */ + +static void XAxisMark PROTO((floatish, floatish)); /* forward */ +static void YAxisMark PROTO((floatish, floatish, mkb)); /* forward */ + +static floatish Round PROTO((floatish)); /* forward */ + +void +Axes() +{ + XAxis(); + YAxis(); +} + +static void +XAxisMark(x, num) + floatish x; floatish num; +{ + /* calibration mark */ + fprintf(psfp, "%f %f moveto\n", xpage(x), ypage(0.0)); + fprintf(psfp, "0 -4 rlineto\n"); + fprintf(psfp, "stroke\n"); + + /* number */ + fprintf(psfp, "HE%d setfont\n", NORMAL_FONT); + fprintf(psfp, "(%.1f)\n", num); + fprintf(psfp, "dup stringwidth pop\n"); + fprintf(psfp, "2 div\n"); + fprintf(psfp, "%f exch sub\n", xpage(x)); + fprintf(psfp, "%f moveto\n", borderspace); + fprintf(psfp, "show\n"); +} + + +#define N_X_MARKS 7 +#define XFUDGE 15 + +extern floatish xrange; +extern char *sampleunitstring; + +static void +XAxis() +{ + floatish increment, i; + floatish t, x; + floatish legendlen; + + /* draw the x axis line */ + fprintf(psfp, "%f %f moveto\n", xpage(0.0), ypage(0.0)); + fprintf(psfp, "%f 0 rlineto\n", graphwidth); + fprintf(psfp, "%f setlinewidth\n", borderthick); + fprintf(psfp, "stroke\n"); + + /* draw x axis legend */ + fprintf(psfp, "HE%d setfont\n", NORMAL_FONT); + fprintf(psfp, "(%s)\n", sampleunitstring); + fprintf(psfp, "dup stringwidth pop\n"); + fprintf(psfp, "%f\n", xpage(0.0) + graphwidth); + fprintf(psfp, "exch sub\n"); + fprintf(psfp, "%f moveto\n", borderspace); + fprintf(psfp, "show\n"); + + + /* draw x axis scaling */ + + increment = Round(xrange / (floatish) N_X_MARKS); + + t = graphwidth / xrange; + legendlen = StringSize(sampleunitstring) + (floatish) XFUDGE; + + for (i = samplemap[0]; i < samplemap[nsamples - 1]; i += increment) { + x = (i - samplemap[0]) * t; + + if (x < (graphwidth - legendlen)) { + XAxisMark(x,i); + } + } +} + +static void +YAxisMark(y, num, unit) + floatish y; floatish num; mkb unit; +{ + /* calibration mark */ + fprintf(psfp, "%f %f moveto\n", xpage(0.0), ypage(y)); + fprintf(psfp, "-4 0 rlineto\n"); + fprintf(psfp, "stroke\n"); + + /* number */ + fprintf(psfp, "HE%d setfont\n", NORMAL_FONT); + + switch (unit) { + case MEGABYTE : + fprintf(psfp, "("); + CommaPrint(psfp, (intish) (num / 1e6 + 0.5)); + fprintf(psfp, "M)\n"); + break; + case KILOBYTE : + fprintf(psfp, "("); + CommaPrint(psfp, (intish) (num / 1e3 + 0.5)); + fprintf(psfp, "k)\n"); + break; + case BYTE: + fprintf(psfp, "("); + CommaPrint(psfp, (intish) (num + 0.5)); + fprintf(psfp, ")\n"); + break; + } + + fprintf(psfp, "dup stringwidth\n"); + fprintf(psfp, "2 div\n"); + fprintf(psfp, "%f exch sub\n", ypage(y)); + + fprintf(psfp, "exch\n"); + fprintf(psfp, "%f exch sub\n", graphx0 - borderspace); + + fprintf(psfp, "exch\n"); + fprintf(psfp, "moveto\n"); + fprintf(psfp, "show\n"); +} + +#define N_Y_MARKS 7 +#define YFUDGE 15 + +extern floatish yrange; +extern char *valueunitstring; + +static void +YAxis() +{ + floatish increment, i; + floatish t, y; + floatish legendlen; + mkb unit; + + /* draw the y axis line */ + fprintf(psfp, "%f %f moveto\n", xpage(0.0), ypage(0.0)); + fprintf(psfp, "0 %f rlineto\n", graphheight); + fprintf(psfp, "%f setlinewidth\n", borderthick); + fprintf(psfp, "stroke\n"); + + /* draw y axis legend */ + fprintf(psfp, "gsave\n"); + fprintf(psfp, "HE%d setfont\n", NORMAL_FONT); + fprintf(psfp, "(%s)\n", valueunitstring); + fprintf(psfp, "dup stringwidth pop\n"); + fprintf(psfp, "%f\n", ypage(0.0) + graphheight); + fprintf(psfp, "exch sub\n"); + fprintf(psfp, "%f exch\n", xpage(0.0) - borderspace); + fprintf(psfp, "translate\n"); + fprintf(psfp, "90 rotate\n"); + fprintf(psfp, "0 0 moveto\n"); + fprintf(psfp, "show\n"); + fprintf(psfp, "grestore\n"); + + /* draw y axis scaling */ + increment = max( yrange / (floatish) N_Y_MARKS, 1.0); + increment = Round(increment); + + if (increment >= 1e6) { + unit = MEGABYTE; + } else if (increment >= 1e3) { + unit = KILOBYTE; + } else { + unit = BYTE; + } + + t = graphheight / yrange; + legendlen = StringSize(valueunitstring) + (floatish) YFUDGE; + + for (i = 0.0; i <= yrange; i += increment) { + y = i * t; + + if (y < (graphheight - legendlen)) { + YAxisMark(y, i, unit); + } + } +} + + +/* + * Find a "nice round" value to use on the axis. + */ + +static floatish OneTwoFive PROTO((floatish)); /* forward */ + +static floatish +Round(y) + floatish y; +{ + int i; + + if (y > 10.0) { + for (i = 0; y > 10.0; y /= 10.0, i++) ; + y = OneTwoFive(y); + for ( ; i > 0; y = y * 10.0, i--) ; + + } else if (y < 1.0) { + for (i = 0; y < 1.0; y *= 10.0, i++) ; + y = OneTwoFive(y); + for ( ; i > 0; y = y / 10.0, i--) ; + + } else { + y = OneTwoFive(y); + } + + return (y); +} + + +/* + * OneTwoFive() -- Runciman's 1,2,5 scaling rule. Argument 1.0 <= y <= 10.0. + */ + +static floatish +OneTwoFive(y) + floatish y; +{ + if (y > 4.0) { + return (5.0); + } else if (y > 1.0) { + return (2.0); + } else { + return (1.0); + } +} diff -ruN ocaml-3.10.0.old/hp/hp2ps/Axes.h ocaml-3.10.0/hp/hp2ps/Axes.h --- ocaml-3.10.0.old/hp/hp2ps/Axes.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Axes.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,6 @@ +#ifndef AXES_H +#define AXES_H + +void Axes PROTO((void)); + +#endif /* AXES_H */ diff -ruN ocaml-3.10.0.old/hp/hp2ps/CHANGES ocaml-3.10.0/hp/hp2ps/CHANGES --- ocaml-3.10.0.old/hp/hp2ps/CHANGES 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/CHANGES 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,37 @@ +1. + +When generating PostScript to show strings, '(' and ')' may need to be escaped. +These characters are now escaped when the JOB string is shown. + +2. + +Manually deleting samples from a .hp file now does what you would expect. + +3. + +The -t flag for setting the threshold percentage has been scrapped. No one +ever used it. + +4. + +Long JOB strings cause hp2ps to use a big title box. Big and small boxes +can be forced with -b and -s flag. + +5. + +MARKS now print as small triangles which remain below the x axis. + +6. + +There is an updated manual page. + +7. + +-m flag for setting maximum no of bands (default 20, cant be more than 20). +-t flag for setting threshold (between 0% and 5%, default 1%). + +8. + +Axes scaling rounding errors removed. + + diff -ruN ocaml-3.10.0.old/hp/hp2ps/Curves.c ocaml-3.10.0/hp/hp2ps/Curves.c --- ocaml-3.10.0.old/hp/hp2ps/Curves.c 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Curves.c 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,164 @@ +#include +#include +#include "Main.h" +#include "Defines.h" +#include "Dimensions.h" +#include "HpFile.h" +#include "Shade.h" +#include "Utilities.h" + +/* own stuff */ +#include "Curves.h" + +static floatish *x; /* x and y values */ +static floatish *y; + +static floatish *py; /* previous y values */ + +static void Curve PROTO((struct entry *)); /* forward */ +static void ShadeCurve(); /* forward */ + +void +Curves() +{ + intish i; + + for (i = 0; i < nidents; i++) { + Curve(identtable[i]); + } +} + +/* + * Draw a curve, and fill the area that is below it and above + * the previous curve. + */ + +static void +Curve(e) + struct entry* e; +{ + struct chunk* ch; + int j; + + for (ch = e->chk; ch; ch = ch->next) { + for (j = 0; j < ch->nd; j++) { + y[ ch->d[j].bucket ] += ch->d[j].value; + } + } + + ShadeCurve(x, y, py, ShadeOf(e->name)); +} + + +static void PlotCurveLeftToRight PROTO((floatish *, floatish *)); /* forward */ +static void PlotCurveRightToLeft PROTO((floatish *, floatish *)); /* forward */ + +static void SaveCurve PROTO((floatish *, floatish *)); /* forward */ + +/* + * Map virtual x coord to physical x coord + */ + +floatish +xpage(x) + floatish x; +{ + return (x + graphx0); +} + + + +/* + * Map virtual y coord to physical y coord + */ + +floatish +ypage(y) + floatish y; +{ + return (y + graphy0); +} + + +/* + * Fill the region bounded by two splines, using the given + * shade. + */ + +static void +ShadeCurve(x, y, py, shade) + floatish *x; floatish *y; floatish *py; floatish shade; +{ + fprintf(psfp, "%f %f moveto\n", xpage(x[0]), ypage(py[0])); + PlotCurveLeftToRight(x, py); + + fprintf(psfp, "%f %f lineto\n", xpage(x[nsamples - 1]), + ypage(y[nsamples - 1])); + PlotCurveRightToLeft(x, y); + + fprintf(psfp, "closepath\n"); + + fprintf(psfp, "gsave\n"); + + SetPSColour(shade); + fprintf(psfp, "fill\n"); + + fprintf(psfp, "grestore\n"); + fprintf(psfp, "stroke\n"); + + SaveCurve(y, py); +} + +static void +PlotCurveLeftToRight(x,y) + floatish *x; floatish *y; +{ + intish i; + + for (i = 0; i < nsamples; i++) { + fprintf(psfp, "%f %f lineto\n", xpage(x[i]), ypage(y[i])); + } +} + +static void +PlotCurveRightToLeft(x,y) + floatish *x; floatish *y; +{ + intish i; + + for (i = nsamples - 1; i >= 0; i-- ) { + fprintf(psfp, "%f %f lineto\n", xpage(x[i]), ypage(y[i])); + } +} + +/* + * Save the curve coordinates stored in y[] in py[]. + */ + +static void +SaveCurve(y, py) + floatish *y; floatish* py; +{ + intish i; + + for (i = 0; i < nsamples; i++) { + py[i] = y[i]; + } +} + +extern floatish xrange; + +void +CurvesInit() +{ + intish i; + + x = (floatish*) xmalloc(nsamples * sizeof(floatish)); + y = (floatish*) xmalloc(nsamples * sizeof(floatish)); + py = (floatish*) xmalloc(nsamples * sizeof(floatish)); + + for (i = 0; i < nsamples; i++) { + x[i] = ((samplemap[i] - samplemap[0])/ xrange) * graphwidth; + y[i] = py[i] = 0.0; + } +} diff -ruN ocaml-3.10.0.old/hp/hp2ps/Curves.h ocaml-3.10.0/hp/hp2ps/Curves.h --- ocaml-3.10.0.old/hp/hp2ps/Curves.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Curves.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,10 @@ +#ifndef CURVES_H +#define CURVES_H + +void Curves PROTO((void)); +void CurvesInit PROTO((void)); + +floatish xpage PROTO((floatish)); +floatish ypage PROTO((floatish)); + +#endif /* CURVES_H */ diff -ruN ocaml-3.10.0.old/hp/hp2ps/Defines.h ocaml-3.10.0/hp/hp2ps/Defines.h --- ocaml-3.10.0.old/hp/hp2ps/Defines.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Defines.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,61 @@ +#ifndef DEFINES_H +#define DEFINES_H + +/* + * Things that can be altered. + */ + +#define THRESHOLD_PERCENT _thresh_ /* all values below 1% insignificant */ +#define DEFAULT_THRESHOLD 1.0 +extern floatish _thresh_; + +#define TWENTY _twenty_ /* show top 20 bands, grouping excess */ +#define DEFAULT_TWENTY 20 /* this is default and absolute maximum */ +extern int _twenty_; + +#define LARGE_FONT 12 /* Helvetica 12pt */ +#define NORMAL_FONT 10 /* Helvetica 10pt */ + +#define BORDER_HEIGHT 432.0 /* page border box 432pt (6 inches high) */ +#define BORDER_WIDTH 648.0 /* page border box 648pt (9 inches wide) */ +#define BORDER_SPACE 5.0 /* page border space */ +#define BORDER_THICK 0.5 /* page border line thickness 0.5pt */ + + +#define TITLE_HEIGHT 20.0 /* title box is 20pt high */ +#define TITLE_TEXT_FONT LARGE_FONT /* title in large font */ +#define TITLE_TEXT_SPACE 6.0 /* space between title text and box */ + + +#define AXIS_THICK 0.5 /* axis thickness 0.5pt */ +#define AXIS_TEXT_SPACE 6 /* space between axis legends and axis */ +#define AXIS_TEXT_FONT NORMAL_FONT /* axis legends in normal font */ +#define AXIS_Y_TEXT_SPACE 35 /* space for y axis text */ + +#define KEY_BOX_WIDTH 14 /* key boxes are 14pt high */ + +#define SMALL_JOB_STRING_WIDTH 35 /* small title for 35 characters or less */ +#define BIG_JOB_STRING_WIDTH 80 /* big title for everything else */ + +#define GRAPH_X0 (AXIS_Y_TEXT_SPACE + (2 * BORDER_SPACE)) +#define GRAPH_Y0 (AXIS_TEXT_FONT + (2 * BORDER_SPACE)) + + +/* + * Things that should be left well alone. + */ + + + +#define START_X 72 /* start 72pt (1 inch) from left (portrait) */ +#define START_Y 108 /* start 108pt (1.5 inch) from bottom (portrait) */ + +#define NUMBER_LENGTH 32 + +#define N_CHUNK 24 + +#define VERSION "0.25" /* as of 95/03/21 */ + +#define max(x,y) ((x) > (y) ? (x) : (y)) /* not everyone has this */ + +#endif /* DEFINES_H */ diff -ruN ocaml-3.10.0.old/hp/hp2ps/Deviation.c ocaml-3.10.0/hp/hp2ps/Deviation.c --- ocaml-3.10.0.old/hp/hp2ps/Deviation.c 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Deviation.c 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,140 @@ +#include +#include +#include +#include "Main.h" +#include "Defines.h" +#include "Error.h" +#include "HpFile.h" +#include "Utilities.h" + +extern void free(); + +/* own stuff */ +#include "Deviation.h" + +/* + * Reorder the identifiers in the identifier table so that the + * ones whose data points exhibit the mininal standard deviation + * come first. + */ + +void +Deviation() +{ + intish i; + intish j; + floatish dev; + struct chunk* ch; + int min; + floatish t; + struct entry* e; + floatish *averages; + floatish *deviations; + + averages = (floatish*) xmalloc(nidents * sizeof(floatish)); + deviations = (floatish*) xmalloc(nidents * sizeof(floatish)); + + /* find averages */ + + for (i = 0; i < nidents; i++) { + averages[i] = 0.0; + } + + for (i = 0; i < nidents; i++) { + for (ch = identtable[i]->chk; ch; ch = ch->next) { + for (j = 0; j < ch->nd; j++) { + averages[i] += ch->d[j].value; + } + } + } + + for (i = 0; i < nidents; i++) { + averages[i] /= (floatish) nsamples; + } + + /* calculate standard deviation */ + + for (i = 0; i < nidents; i++) { + deviations[i] = 0.0; + } + + for (i = 0; i < nidents; i++) { + for (ch = identtable[i]->chk; ch; ch = ch->next) { + for (j = 0; j < ch->nd; j++) { + dev = ch->d[j].value - averages[i]; + deviations[i] += dev * dev; + } + } + } + + for (i = 0; i < nidents; i++) { + deviations[i] = (floatish) sqrt ((doublish) (deviations[i] / + (floatish) (nsamples - 1))); + } + + + /* sort on basis of standard deviation */ + + for (i = 0; i < nidents-1; i++) { + min = i; + for (j = i+1; j < nidents; j++) { + if (deviations[ j ] < deviations[min]) { + min = j; + } + } + + t = deviations[min]; + deviations[min] = deviations[i]; + deviations[i] = t; + + e = identtable[min]; + identtable[min] = identtable[i]; + identtable[i] = e; + } + + free(averages); + free(deviations); +} + +void +Identorder(iflag) + int iflag; /* a funny three-way flag ? WDP 95/03 */ +{ + int i; + int j; + int min; + struct entry* e; + + /* sort on basis of ident string */ + if (iflag > 0) { + /* greatest at top i.e. smallest at start */ + + for (i = 0; i < nidents-1; i++) { + min = i; + for (j = i+1; j < nidents; j++) { + if (strcmp(identtable[j]->name, identtable[min]->name) < 0) { + min = j; + } + } + + e = identtable[min]; + identtable[min] = identtable[i]; + identtable[i] = e; + } + } else { + /* smallest at top i.e. greatest at start */ + + for (i = 0; i < nidents-1; i++) { + min = i; + for (j = i+1; j < nidents; j++) { + if (strcmp(identtable[j]->name, identtable[min]->name) > 0) { + min = j; + } + } + + e = identtable[min]; + identtable[min] = identtable[i]; + identtable[i] = e; + } + } +} diff -ruN ocaml-3.10.0.old/hp/hp2ps/Deviation.h ocaml-3.10.0/hp/hp2ps/Deviation.h --- ocaml-3.10.0.old/hp/hp2ps/Deviation.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Deviation.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,7 @@ +#ifndef DEVIATION_H +#define DEVIATION_H + +void Deviation PROTO((void)); +void Identorder PROTO((int)); + +#endif /* DEVIATION_H */ diff -ruN ocaml-3.10.0.old/hp/hp2ps/Dimensions.c ocaml-3.10.0/hp/hp2ps/Dimensions.c --- ocaml-3.10.0.old/hp/hp2ps/Dimensions.c 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Dimensions.c 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,203 @@ +#include +#include +#include +#include "Main.h" +#include "Defines.h" +#include "HpFile.h" +#include "Scale.h" + +/* own stuff */ +#include "Dimensions.h" + +/* + * Get page and other dimensions before printing. + */ + +floatish borderheight = BORDER_HEIGHT; +floatish borderwidth = BORDER_WIDTH; +floatish borderspace = BORDER_SPACE; +floatish borderthick = BORDER_THICK; + +floatish titlewidth = (BORDER_WIDTH - (2 * BORDER_SPACE)); +floatish titletextspace = TITLE_TEXT_SPACE; +floatish titleheight; + +floatish graphx0 = GRAPH_X0; +floatish graphy0 = GRAPH_Y0; + +floatish graphheight; +floatish graphwidth; + +static floatish KeyWidth PROTO((void)); /* forward */ + +void +Dimensions() +{ + xrange = samplemap[nsamples - 1] - samplemap[0]; + xrange = max(xrange, auxxrange); + if (xrange == 0.0) xrange = 1.0; /* avoid division by 0.0 */ + + yrange = MaxCombinedHeight(); + yrange = max(yrange, auxyrange); + if (yrange == 0.0) yrange = 1.0; /* avoid division by 0.0 */ + + if (!bflag && !sflag) { + bflag = strlen(jobstring) > SMALL_JOB_STRING_WIDTH; + } + + if (bflag) { + titleheight = 2 * TITLE_HEIGHT; + } else { + titleheight = TITLE_HEIGHT; + } + + graphwidth = titlewidth - graphx0 - (TWENTY ? KeyWidth() : 0); + graphheight = borderheight - titleheight - (2 * borderspace) - graphy0; +} + +/* + * Calculate the width of the key. + */ + +static floatish +KeyWidth() +{ + intish i; + floatish c; + + c = 0.0; + + for (i = 0; i < nidents; i++) { + c = max(c, StringSize(identtable[i]->name)); + } + + c += 3.0 * borderspace; + + c += (floatish) KEY_BOX_WIDTH; + + return c; +} + + +/* + * A desperately grim solution. + */ + + +floatish fonttab[] = { + /* 20 (' ') = */ 3.0, + /* 21 ('!') = */ 1.0, + /* 22 ('"') = */ 1.0, + /* 23 ('#') = */ 3.0, + /* 24 ('$') = */ 3.0, + /* 25 ('%') = */ 3.0, + /* 26 ('&') = */ 3.0, + /* 27 (''') = */ 1.0, + /* 28 ('(') = */ 3.0, + /* 29 (')') = */ 3.0, + /* 2a ('*') = */ 2.0, + /* 2b ('+') = */ 3.0, + /* 2c (',') = */ 1.0, + /* 2d ('-') = */ 3.0, + /* 2e ('.') = */ 1.0, + /* 2f ('/') = */ 3.0, + /* 30 ('0') = */ 4.0, + /* 31 ('1') = */ 4.0, + /* 32 ('2') = */ 4.0, + /* 33 ('3') = */ 4.0, + /* 34 ('4') = */ 4.0, + /* 35 ('5') = */ 4.0, + /* 36 ('6') = */ 4.0, + /* 37 ('7') = */ 4.0, + /* 38 ('8') = */ 4.0, + /* 39 ('9') = */ 4.0, + /* 3a (':') = */ 1.0, + /* 3b (';') = */ 1.0, + /* 3c ('<') = */ 3.0, + /* 3d ('=') = */ 3.0, + /* 3e ('>') = */ 3.0, + /* 3f ('?') = */ 2.0, + /* 40 ('@') = */ 3.0, + /* 41 ('A') = */ 5.0, + /* 42 ('B') = */ 5.0, + /* 43 ('C') = */ 5.0, + /* 44 ('D') = */ 5.0, + /* 45 ('E') = */ 5.0, + /* 46 ('F') = */ 5.0, + /* 47 ('G') = */ 5.0, + /* 48 ('H') = */ 5.0, + /* 49 ('I') = */ 1.0, + /* 4a ('J') = */ 5.0, + /* 4b ('K') = */ 5.0, + /* 4c ('L') = */ 5.0, + /* 4d ('M') = */ 5.0, + /* 4e ('N') = */ 5.0, + /* 4f ('O') = */ 5.0, + /* 50 ('P') = */ 5.0, + /* 51 ('Q') = */ 5.0, + /* 52 ('R') = */ 5.0, + /* 53 ('S') = */ 5.0, + /* 54 ('T') = */ 5.0, + /* 55 ('U') = */ 5.0, + /* 56 ('V') = */ 5.0, + /* 57 ('W') = */ 5.0, + /* 58 ('X') = */ 5.0, + /* 59 ('Y') = */ 5.0, + /* 5a ('Z') = */ 5.0, + /* 5b ('[') = */ 2.0, + /* 5c ('\') = */ 3.0, + /* 5d (']') = */ 2.0, + /* 5e ('^') = */ 1.0, + /* 5f ('_') = */ 3.0, + /* 60 ('`') = */ 1.0, + /* 61 ('a') = */ 3.0, + /* 62 ('b') = */ 3.0, + /* 63 ('c') = */ 3.0, + /* 64 ('d') = */ 3.0, + /* 65 ('e') = */ 3.0, + /* 66 ('f') = */ 3.0, + /* 67 ('g') = */ 3.0, + /* 68 ('h') = */ 3.0, + /* 69 ('i') = */ 1.0, + /* 6a ('j') = */ 2.0, + /* 6b ('k') = */ 3.0, + /* 6c ('l') = */ 1.0, + /* 6d ('m') = */ 5.0, + /* 6e ('n') = */ 3.0, + /* 6f ('o') = */ 3.0, + /* 70 ('p') = */ 3.0, + /* 71 ('q') = */ 3.0, + /* 72 ('r') = */ 2.0, + /* 73 ('s') = */ 3.0, + /* 74 ('t') = */ 2.0, + /* 75 ('u') = */ 3.0, + /* 76 ('v') = */ 3.0, + /* 77 ('w') = */ 3.0, + /* 78 ('x') = */ 3.0, + /* 79 ('y') = */ 3.0, + /* 7a ('z') = */ 3.0, + /* 7b ('{') = */ 2.0, + /* 7c ('|') = */ 1.0, + /* 7d ('}') = */ 2.0, + /* 7e ('~') = */ 2.0 +}; + + +/* + * What size is a string (in points)? + */ + +#define FUDGE (2.834646 * 0.6) + +floatish +StringSize(s) + char* s; +{ + floatish r; + + for (r = 0.0; *s; s++) { + r += fonttab[(*s) - 0x20]; + } + + return r * FUDGE; +} diff -ruN ocaml-3.10.0.old/hp/hp2ps/Dimensions.h ocaml-3.10.0/hp/hp2ps/Dimensions.h --- ocaml-3.10.0.old/hp/hp2ps/Dimensions.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Dimensions.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,22 @@ +#ifndef DIMENSIONS_H +#define DIMENSIONS_H + +extern floatish borderheight; +extern floatish borderwidth; +extern floatish borderspace; +extern floatish borderthick; + +extern floatish titleheight; +extern floatish titlewidth; +extern floatish titletextspace; + +extern floatish graphx0; +extern floatish graphy0; + +extern floatish graphheight; +extern floatish graphwidth; + +void Dimensions PROTO((void)); +floatish StringSize PROTO((char *)); + +#endif /* DIMENSIONS_H */ diff -ruN ocaml-3.10.0.old/hp/hp2ps/Error.c ocaml-3.10.0/hp/hp2ps/Error.c --- ocaml-3.10.0.old/hp/hp2ps/Error.c 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Error.c 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,55 @@ +#include +#include "Main.h" +#include "Defines.h" + +/* own stuff */ +#include "Error.h" + +void exit PROTO((int)); + +/*VARARGS0*/ +void +Error(a1,a2,a3,a4) + char* a1; char* a2; char* a3; char* a4; +{ + fflush(stdout); + fprintf(stderr, "%s: ", programname); + fprintf(stderr, a1, a2, a3, a4); + fprintf(stderr, "\n"); + exit(1); +} + +/*VARARGS0*/ +void +Disaster(a1,a2,a3,a4) + char* a1; char* a2; char* a3; char* a4; +{ + fflush(stdout); + fprintf(stderr, "%s: ", programname); + fprintf(stderr, " Disaster! ("); + fprintf(stderr, a1, a2, a3, a4); + fprintf(stderr, ")\n"); + exit(1); +} + +void +Usage(str) + char *str; +{ + if (str) printf("error: %s\n", str); + printf("usage: %s -b -d -ef -g -i -p -mn -p -s -tf -y [file[.hp]]\n", programname); + printf("where -b use large title box\n"); + printf(" -d sort by standard deviation\n"); + printf(" -ef[in|mm|pt] produce Encapsulated PostScript f units wide (f > 2 inches)\n"); + printf(" -g produce output suitable for GHOSTSCRIPT previever\n"); + printf(" -i[+|-] sort by identifier string (-i+ gives greatest on top) \n"); + printf(" -mn print maximum of n bands (default & max 20)\n"); + printf(" -m0 removes the band limit altogether\n"); + printf(" -p use previous scaling, shading and ordering\n"); + printf(" -s use small title box\n"); + printf(" -tf ignore trace bands which sum below f%% (default 1%%, max 5%%)\n"); + printf(" -y traditional\n"); + printf(" -c colour ouput\n"); + exit(0); +} + diff -ruN ocaml-3.10.0.old/hp/hp2ps/Error.h ocaml-3.10.0/hp/hp2ps/Error.h --- ocaml-3.10.0.old/hp/hp2ps/Error.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Error.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,8 @@ +#ifndef ERROR_H +#define ERROR_H + +extern void Error (); /*PROTO((char *, ...)); */ +extern void Disaster (); /* PROTO((char *, ...)); */ +extern void Usage (); /* PROTO((char *)); */ + +#endif /* ERROR_H */ diff -ruN ocaml-3.10.0.old/hp/hp2ps/HpFile.c ocaml-3.10.0/hp/hp2ps/HpFile.c --- ocaml-3.10.0.old/hp/hp2ps/HpFile.c 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/HpFile.c 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,587 @@ +#include +#include +#include +#include +#include "Main.h" +#include "Defines.h" +#include "Error.h" +#include "HpFile.h" +#include "Utilities.h" + +#ifndef atof +double atof PROTO((const char *)); +#endif + +/* own stuff already included */ + +#define N_MARKS 50 /* start size of the mark table */ +#define N_SAMPLES 500 /* start size of the sample table */ + +char *theident; +char *thestring; +int theinteger; +floatish thefloatish; +int ch; /* last character read */ +token thetok; /* last token */ +int linenum; /* current line number */ +int endfile; /* true at end of file */ + +static boolish gotjob = 0; /* "JOB" read */ +static boolish gotdate = 0; /* "DATE" read */ +static boolish gotvalueunit = 0; /* "VALUE_UNIT" read */ +static boolish gotsampleunit = 0; /* "SAMPLE_UNIT" read */ +static boolish insample = 0; /* true when in sample */ + +static floatish lastsample; /* the last sample time */ + +static void GetHpLine PROTO((FILE *)); /* forward */ +static void GetHpTok PROTO((FILE *)); /* forward */ + +static struct entry *GetEntry PROTO((char *)); /* forward */ + +static void MakeIdentTable PROTO((void)); /* forward */ + +char *jobstring; +char *datestring; + +char *sampleunitstring; +char *valueunitstring; + +floatish *samplemap; /* sample intervals */ +floatish *markmap; /* sample marks */ + +/* + * An extremely simple parser. The input is organised into lines of + * the form + * + * JOB s -- job identifier string + * DATE s -- date string + * SAMPLE_UNIT s -- sample unit eg "seconds" + * VALUE_UNIT s -- value unit eg "bytes" + * MARK i -- sample mark + * BEGIN_SAMPLE i -- start of ith sample + * identifier i -- there are i identifiers in this sample + * END_SAMPLE i -- end of ith sample + * + */ + +void +GetHpFile(infp) + FILE *infp; +{ + nsamples = 0; + nmarks = 0; + nidents = 0; + + ch = ' '; + endfile = 0; + linenum = 1; + lastsample = 0.0; + + GetHpTok(infp); + + while (endfile == 0) { + GetHpLine(infp); + } + + if (!gotjob) { + Error("%s: JOB missing", hpfile); + } + + if (!gotdate) { + Error("%s: DATE missing", hpfile); + } + + if (!gotvalueunit) { + Error("%s: VALUE_UNIT missing", hpfile); + } + + if (!gotsampleunit) { + Error("%s: SAMPLE_UNIT missing", hpfile); + } + + if (nsamples == 0) { + Error("%s: contains no samples", hpfile); + } + + + MakeIdentTable(); + + fclose(hpfp); +} + + +/* + * Read the next line from the input, check the syntax, and perform + * the appropriate action. + */ + +static void +GetHpLine(infp) + FILE* infp; +{ + static intish nmarkmax = 0, nsamplemax = 0; + + switch (thetok) { + case JOB_TOK: + GetHpTok(infp); + if (thetok != STRING_TOK) { + Error("%s, line %d: string must follow JOB", hpfile, linenum); + } + jobstring = thestring; + gotjob = 1; + GetHpTok(infp); + break; + + case DATE_TOK: + GetHpTok(infp); + if (thetok != STRING_TOK) { + Error("%s, line %d: string must follow DATE", hpfile, linenum); + } + datestring = thestring; + gotdate = 1; + GetHpTok(infp); + break; + + case SAMPLE_UNIT_TOK: + GetHpTok(infp); + if (thetok != STRING_TOK) { + Error("%s, line %d: string must follow SAMPLE_UNIT", hpfile, + linenum); + } + sampleunitstring = thestring; + gotsampleunit = 1; + GetHpTok(infp); + break; + + case VALUE_UNIT_TOK: + GetHpTok(infp); + if (thetok != STRING_TOK) { + Error("%s, line %d: string must follow VALUE_UNIT", hpfile, + linenum); + } + valueunitstring = thestring; + gotvalueunit = 1; + GetHpTok(infp); + break; + + case MARK_TOK: + GetHpTok(infp); + if (thetok != FLOAT_TOK) { + Error("%s, line %d, floating point number must follow MARK", + hpfile, linenum); + } + if (insample) { + Error("%s, line %d, MARK occurs within sample", hpfile, linenum); + } + if (nmarks >= nmarkmax) { + if (!markmap) { + nmarkmax = N_MARKS; + markmap = (floatish*) xmalloc(nmarkmax * sizeof(floatish)); + } else { + nmarkmax *= 2; + markmap = (floatish*) xrealloc(markmap, nmarkmax * sizeof(floatish)); + } + } + markmap[ nmarks++ ] = thefloatish; + GetHpTok(infp); + break; + + case BEGIN_SAMPLE_TOK: + insample = 1; + GetHpTok(infp); + if (thetok != FLOAT_TOK) { + Error("%s, line %d, floating point number must follow BEGIN_SAMPLE", hpfile, linenum); + } + if (thefloatish < lastsample) { + Error("%s, line %d, samples out of sequence", hpfile, linenum); + } else { + lastsample = thefloatish; + } + if (nsamples >= nsamplemax) { + if (!samplemap) { + nsamplemax = N_SAMPLES; + samplemap = (floatish*) xmalloc(nsamplemax * sizeof(floatish)); + } else { + nsamplemax *= 2; + samplemap = (floatish*) xrealloc(samplemap, + nsamplemax * sizeof(floatish)); + } + } + samplemap[ nsamples ] = thefloatish; + GetHpTok(infp); + break; + + case END_SAMPLE_TOK: + insample = 0; + GetHpTok(infp); + if (thetok != FLOAT_TOK) { + Error("%s, line %d: floating point number must follow END_SAMPLE", + hpfile, linenum); + } + nsamples++; + GetHpTok(infp); + break; + + case IDENTIFIER_TOK: + GetHpTok(infp); + if (thetok != INTEGER_TOK) { + Error("%s, line %d: integer must follow identifier", hpfile, + linenum); + } + StoreSample(GetEntry(theident), nsamples, (floatish) theinteger); + GetHpTok(infp); + break; + + case EOF_TOK: + endfile = 1; + break; + + default: + Error("%s, line %d: %s unexpected", hpfile, linenum, + TokenToString(thetok)); + break; + } +} + + +char * +TokenToString(t) + token t; +{ + switch (t) { + case EOF_TOK: return "EOF"; + case INTEGER_TOK: return "integer"; + case FLOAT_TOK: return "floating point number"; + case IDENTIFIER_TOK: return "identifier"; + case STRING_TOK: return "string"; + case BEGIN_SAMPLE_TOK: return "BEGIN_SAMPLE"; + case END_SAMPLE_TOK: return "END_SAMPLE"; + case JOB_TOK: return "JOB"; + case DATE_TOK: return "DATE"; + case SAMPLE_UNIT_TOK: return "SAMPLE_UNIT"; + case VALUE_UNIT_TOK: return "VALUE_UNIT"; + case MARK_TOK: return "MARK"; + + case X_RANGE_TOK: return "X_RANGE"; + case Y_RANGE_TOK: return "Y_RANGE"; + case ORDER_TOK: return "ORDER"; + case SHADE_TOK: return "SHADE"; + default: return "(strange token)"; + } +} + +/* + * Read the next token from the input and assign its value + * to the global variable "thetok". In the case of numbers, + * the corresponding value is also assigned to "theinteger" + * or "thefloatish" as appropriate; in the case of identifiers + * it is assigned to "theident". + */ + +static void +GetHpTok(infp) + FILE* infp; +{ + + while (isspace(ch)) { /* skip whitespace */ + if (ch == '\n') linenum++; + ch = getc(infp); + } + + if (ch == EOF) { + thetok = EOF_TOK; + return; + } + + if (isdigit(ch)) { + thetok = GetNumber(infp); + return; + } else if (ch == '\"') { + GetString(infp); + thetok = STRING_TOK; + return; + } else if (IsIdChar(ch)) { + ASSERT(! (isdigit(ch))); /* ch can't be a digit here */ + GetIdent(infp); + if (!isupper(theident[0])) { + thetok = IDENTIFIER_TOK; + } else if (strcmp(theident, "BEGIN_SAMPLE") == 0) { + thetok = BEGIN_SAMPLE_TOK; + } else if (strcmp(theident, "END_SAMPLE") == 0) { + thetok = END_SAMPLE_TOK; + } else if (strcmp(theident, "JOB") == 0) { + thetok = JOB_TOK; + } else if (strcmp(theident, "DATE") == 0) { + thetok = DATE_TOK; + } else if (strcmp(theident, "SAMPLE_UNIT") == 0) { + thetok = SAMPLE_UNIT_TOK; + } else if (strcmp(theident, "VALUE_UNIT") == 0) { + thetok = VALUE_UNIT_TOK; + } else if (strcmp(theident, "MARK") == 0) { + thetok = MARK_TOK; + } else { + thetok = IDENTIFIER_TOK; + } + return; + } else { + Error("%s, line %d: strange character (%c)", hpfile, linenum, ch); + } +} + + +/* + * Read a sequence of digits and convert the result to an integer + * or floating point value (assigned to the "theinteger" or + * "thefloatish"). + */ + +static char numberstring[ NUMBER_LENGTH - 1 ]; + +token +GetNumber(infp) + FILE* infp; +{ + int i; + int containsdot; + + ASSERT(isdigit(ch)); /* we must have a digit to start with */ + + containsdot = 0; + + for (i = 0; i < NUMBER_LENGTH && (isdigit(ch) || ch == '.'); i++) { + numberstring[ i ] = ch; + containsdot |= (ch == '.'); + ch = getc(infp); + } + + ASSERT(i < NUMBER_LENGTH); /* did not overflow */ + + numberstring[ i ] = '\0'; + + if (containsdot) { + thefloatish = (floatish) atof(numberstring); + return FLOAT_TOK; + } else { + theinteger = atoi(numberstring); + return INTEGER_TOK; + } +} + +/* + * Read a sequence of identifier characters and assign the result + * to the string "theident". + */ + +void +GetIdent(infp) + FILE *infp; +{ + unsigned int i; + char idbuffer[5000]; + + for (i = 0; i < (sizeof idbuffer)-1 && IsIdChar(ch); i++) { + idbuffer[ i ] = ch; + ch = getc(infp); + } + + idbuffer[ i ] = '\0'; + + if (theident) + free(theident); + + theident = copystring(idbuffer); +} + + +/* + * Read a sequence of characters that make up a string and + * assign the result to "thestring". + */ + +void +GetString(infp) + FILE *infp; +{ + unsigned int i; + char stringbuffer[5000]; + + ASSERT(ch == '\"'); + + ch = getc(infp); /* skip the '\"' that begins the string */ + + for (i = 0; i < (sizeof stringbuffer)-1 && ch != '\"'; i++) { + stringbuffer[ i ] = ch; + ch = getc(infp); + } + + stringbuffer[i] = '\0'; + thestring = copystring(stringbuffer); + + ASSERT(ch == '\"'); + + ch = getc(infp); /* skip the '\"' that terminates the string */ +} + +boolish +IsIdChar(ch) + int ch; +{ + return (!isspace(ch)); +} + + +/* + * The information associated with each identifier is stored + * in a linked list of chunks. The table below allows the list + * of chunks to be retrieved given an identifier name. + */ + +#define N_HASH 513 + +static struct entry* hashtable[ N_HASH ]; + +static intish +Hash(s) + char *s; +{ + int r; + + for (r = 0; *s; s++) { + r = r + r + r + *s; + } + + if (r < 0) r = -r; + + return r % N_HASH; +} + +/* + * Get space for a new chunk. Initialise it, and return a pointer + * to the new chunk. + */ + +static struct chunk* +MakeChunk() +{ + struct chunk* ch; + struct datapoint* d; + + ch = (struct chunk*) xmalloc( sizeof(struct chunk) ); + + d = (struct datapoint*) xmalloc (sizeof(struct datapoint) * N_CHUNK); + + ch->nd = 0; + ch->d = d; + ch->next = 0; + return ch; +} + + +/* + * Get space for a new entry. Initialise it, and return a pointer + * to the new entry. + */ + +struct entry * +MakeEntry(name) + char *name; +{ + struct entry* e; + + e = (struct entry *) xmalloc(sizeof(struct entry)); + e->chk = MakeChunk(); + e->name = copystring(name); + return e; +} + +/* + * Get the entry associated with "name", creating a new entry if + * necessary. + */ + +static struct entry * +GetEntry(name) + char* name; +{ + intish h; + struct entry* e; + + h = Hash(name); + + for (e = hashtable[ h ]; e; e = e->next) { + if (strcmp(e->name, name) == 0) { + break; + } + } + + if (e) { + return (e); + } else { + nidents++; + e = MakeEntry(name); + e->next = hashtable[ h ]; + hashtable[ h ] = e; + return (e); + } +} + + +/* + * Store information from a sample. + */ + +void +StoreSample(en, bucket, value) + struct entry* en; intish bucket; floatish value; +{ + struct chunk* chk; + + for (chk = en->chk; chk->next != 0; chk = chk->next) + ; + + if (chk->nd < N_CHUNK) { + chk->d[ chk->nd ].bucket = bucket; + chk->d[ chk->nd ].value = value; + chk->nd += 1; + } else { + struct chunk* t; + t = chk->next = MakeChunk(); + t->d[ 0 ].bucket = bucket; + t->d[ 0 ].value = value; + t->nd += 1; + } +} + + +struct entry** identtable; + +/* + * The hash table is useful while reading the input, but it + * becomes a liability thereafter. The code below converts + * it to a more easily processed table. + */ + +static void +MakeIdentTable() +{ + intish i; + intish j; + struct entry* e; + + nidents = 0; + for (i = 0; i < N_HASH; i++) { + for (e = hashtable[ i ]; e; e = e->next) { + nidents++; + } + } + + identtable = (struct entry**) xmalloc(nidents * sizeof(struct entry*)); + j = 0; + + for (i = 0; i < N_HASH; i++) { + for (e = hashtable[ i ]; e; e = e->next, j++) { + identtable[ j ] = e; + } + } +} diff -ruN ocaml-3.10.0.old/hp/hp2ps/HpFile.h ocaml-3.10.0/hp/hp2ps/HpFile.h --- ocaml-3.10.0.old/hp/hp2ps/HpFile.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/HpFile.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,77 @@ +#ifndef HP_FILE_H +#define HP_FILE_H + +typedef enum { + /* These tokens are found in ".hp" files */ + + EOF_TOK, + INTEGER_TOK, + FLOAT_TOK, + IDENTIFIER_TOK, + STRING_TOK, + BEGIN_SAMPLE_TOK, + END_SAMPLE_TOK, + JOB_TOK, + DATE_TOK, + SAMPLE_UNIT_TOK, + VALUE_UNIT_TOK, + MARK_TOK, + + /* These extra ones are found only in ".aux" files */ + + X_RANGE_TOK, + Y_RANGE_TOK, + ORDER_TOK, + SHADE_TOK +} token; + +struct datapoint { + int bucket; + floatish value; +}; + +struct chunk { + struct chunk *next; + short nd; /* 0 .. N_CHUNK - 1 */ + struct datapoint *d; +}; + + +struct entry { + struct entry *next; + struct chunk *chk; + char *name; +}; + +extern char *theident; +extern char *thestring; +extern int theinteger; +extern floatish thefloatish; +extern int ch; +extern token thetok; +extern int linenum; +extern int endfile; + +char *TokenToString PROTO((token)); + +extern struct entry** identtable; + +extern floatish *samplemap; +extern floatish *markmap; + +void GetHpFile PROTO((FILE *)); +void StoreSample PROTO((struct entry *, intish, floatish)); +struct entry *MakeEntry PROTO((char *)); + +token GetNumber PROTO((FILE *)); +void GetIdent PROTO((FILE *)); +void GetString PROTO((FILE *)); +boolish IsIdChar PROTO((int)); /* int is a "char" from getc */ + +extern char *jobstring; +extern char *datestring; + +extern char *sampleunitstring; +extern char *valueunitstring; + +#endif /* HP_FILE_H */ diff -ruN ocaml-3.10.0.old/hp/hp2ps/Key.c ocaml-3.10.0/hp/hp2ps/Key.c --- ocaml-3.10.0.old/hp/hp2ps/Key.c 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Key.c 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,63 @@ +#include +#include +#include "Main.h" +#include "Defines.h" +#include "Dimensions.h" +#include "HpFile.h" +#include "Shade.h" + +/* own stuff */ +#include "Key.h" + +static void KeyEntry PROTO((floatish, char *, floatish)); + +void Key() +{ + intish i; + floatish c; + floatish dc; + + for (i = 0; i < nidents; i++) /* count identifiers */ + ; + + c = graphy0; + dc = graphheight / (floatish) (i + 1); + + for (i = 0; i < nidents; i++) { + c += dc; + KeyEntry(c, identtable[i]->name, ShadeOf(identtable[i]->name)); + } +} + + + +static void +KeyEntry(centreline, name, colour) + floatish centreline; char* name; floatish colour; +{ + floatish namebase; + floatish keyboxbase; + floatish kstart; + + namebase = centreline - (floatish) (NORMAL_FONT / 2); + keyboxbase = centreline - ((floatish) KEY_BOX_WIDTH / 2.0); + + kstart = graphx0 + graphwidth; + + fprintf(psfp, "%f %f moveto\n", kstart + borderspace, keyboxbase); + fprintf(psfp, "0 %d rlineto\n", KEY_BOX_WIDTH); + fprintf(psfp, "%d 0 rlineto\n", KEY_BOX_WIDTH); + fprintf(psfp, "0 %d rlineto\n", -KEY_BOX_WIDTH); + fprintf(psfp, "closepath\n"); + + fprintf(psfp, "gsave\n"); + SetPSColour(colour); + fprintf(psfp, "fill\n"); + fprintf(psfp, "grestore\n"); + fprintf(psfp, "stroke\n"); + + fprintf(psfp, "HE%d setfont\n", NORMAL_FONT); + fprintf(psfp, "%f %f moveto\n", kstart + (floatish) KEY_BOX_WIDTH + 2 * borderspace, namebase); + + fprintf(psfp, "(%s) show\n", name); +} diff -ruN ocaml-3.10.0.old/hp/hp2ps/Key.h ocaml-3.10.0/hp/hp2ps/Key.h --- ocaml-3.10.0.old/hp/hp2ps/Key.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Key.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,6 @@ +#ifndef KEY_H +#define KEY_H + +void Key PROTO((void)); + +#endif /* KEY_H */ diff -ruN ocaml-3.10.0.old/hp/hp2ps/Main.c ocaml-3.10.0/hp/hp2ps/Main.c --- ocaml-3.10.0.old/hp/hp2ps/Main.c 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Main.c 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,253 @@ +#include +#include +#include +#include "Main.h" +#include "Defines.h" +#include "AuxFile.h" +#include "AreaBelow.h" +#include "Dimensions.h" +#include "HpFile.h" +#include "PsFile.h" +#include "Reorder.h" +#include "Scale.h" +#include "TopTwenty.h" +#include "TraceElement.h" +#include "Deviation.h" +#include "Error.h" +#include "Utilities.h" + +boolish pflag = 0; /* read auxiliary file */ +boolish eflag = 0; /* scaled EPSF */ +boolish dflag = 0; /* sort by standard deviation */ +int iflag = 0; /* sort by identifier (3-way flag) */ +boolish gflag = 0; /* output suitable for previewer */ +boolish yflag = 0; /* ignore marks */ +boolish bflag = 0; /* use a big title box */ +boolish sflag = 0; /* use a small title box */ +int mflag = 0; /* max no. of bands displayed (default 20) */ +boolish tflag = 0; /* ignored threshold specified */ +boolish cflag = 0; /* colour output */ + +boolish filter; /* true when running as a filter */ + +static floatish WidthInPoints PROTO((char *)); /* forward */ +static FILE *Fp PROTO((char *, char **, char *, char *)); /* forward */ + +char *hpfile; +char *psfile; +char *auxfile; + +char *programname; + +static char *pathName; +static char *baseName; /* "basename" is a std C library name (sigh) */ + +FILE* hpfp; +FILE* psfp; +FILE* auxfp; + +floatish xrange = 0.0; +floatish yrange = 0.0; + +floatish auxxrange = 0.0; +floatish auxyrange = 0.0; + +floatish epsfwidth; +floatish areabelow; + +intish nsamples; +intish nmarks; +intish nidents; + +floatish THRESHOLD_PERCENT = DEFAULT_THRESHOLD; +int TWENTY = DEFAULT_TWENTY; + +int main(argc, argv) +int argc; +char* argv[]; +{ + + programname = copystring(Basename(argv[0])); + + argc--, argv++; + while (argc && argv[0][0] == '-') { + while (*++*argv) + switch(**argv) { + case 'p': + pflag++; + break; + case 'e': + eflag++; + epsfwidth = WidthInPoints(*argv + 1); + goto nextarg; + case 'd': + dflag++; + goto nextarg; + case 'i': + switch( *(*argv + 1) ) { + case '-': + iflag = -1; + case '+': + default: + iflag = 1; + } + goto nextarg; + case 'g': + gflag++; + goto nextarg; + case 'y': + yflag++; + goto nextarg; + case 'b': + bflag++; + goto nextarg; + case 's': + sflag++; + goto nextarg; + case 'm': + mflag++; + TWENTY = atoi(*argv + 1); + if (TWENTY > DEFAULT_TWENTY) + Usage(*argv-1); + goto nextarg; + case 't': + tflag++; + THRESHOLD_PERCENT = (floatish) atof(*argv + 1); + if (THRESHOLD_PERCENT < 0 || THRESHOLD_PERCENT > 5) + Usage(*argv-1); + goto nextarg; + case 'c': + cflag++; + goto nextarg; + case '?': + default: + Usage(*argv-1); + } +nextarg: ; + argc--, argv++; + } + + hpfile = "stdin"; + psfile = "stdout"; + + hpfp = stdin; + psfp = stdout; + + filter = argc < 1; + + + + if (!filter) { + pathName = copystring(argv[0]); + DropSuffix(pathName, ".hp"); + baseName = copystring(Basename(pathName)); + + hpfp = Fp(pathName, &hpfile, ".hp", "r"); + psfp = Fp(baseName, &psfile, ".ps", "w"); + + if (pflag) auxfp = Fp(baseName, &auxfile, ".aux", "r"); + } + + GetHpFile(hpfp); + + if (!filter && pflag) GetAuxFile(auxfp); + + + TraceElement(); /* Orders on total, Removes trace elements (tflag) */ + + if (dflag) Deviation(); /* ReOrders on deviation */ + + if (iflag) Identorder(iflag); /* ReOrders on identifier */ + + if (pflag) Reorder(); /* ReOrders on aux file */ + + if (TWENTY) TopTwenty(); /* Selects top twenty (mflag) */ + + Dimensions(); + + areabelow = AreaBelow(); + + Scale(); + + PutPsFile(); + + if (!filter) { + auxfp = Fp(baseName, &auxfile, ".aux", "w"); + PutAuxFile(auxfp); + } + + return(0); +} + + + +typedef enum {POINTS, INCHES, MILLIMETRES} pim; + +static pim Units PROTO((char *)); /* forward */ + +static floatish +WidthInPoints(wstr) + char *wstr; +{ + floatish result; + + result = (floatish) atof(wstr); + + switch (Units(wstr)) { + case INCHES: + result *= 72.0; + break; + case MILLIMETRES: + result *= 2.834646; + break; + case POINTS: + default: ; + } + + if (result <= 144) /* Minimum of 2in wide ! */ + Usage(wstr); + + return result; +} + + +static pim +Units(wstr) + char* wstr; +{ +int i; + + i = strlen(wstr) - 2; + + if (wstr[i] == 'p' && wstr[i+1] == 't') { + return POINTS; + } else if (wstr[i] == 'i' && wstr[i+1] == 'n') { + return INCHES; + } else if (wstr[i] == 'm' && wstr[i+1] == 'm') { + return MILLIMETRES; + } else { + return POINTS; + } +} + +static FILE * +Fp(rootname, filename, suffix, mode) + char* rootname; char** filename; char* suffix; char* mode; +{ + *filename = copystring2(rootname, suffix); + + return(OpenFile(*filename, mode)); +} + +#ifdef DEBUG +void +_stgAssert (filename, linenum) + char *filename; + unsigned int linenum; +{ + fflush(stdout); + fprintf(stderr, "ASSERTION FAILED: file %s, line %u\n", filename, linenum); + fflush(stderr); + abort(); +} +#endif diff -ruN ocaml-3.10.0.old/hp/hp2ps/Main.h ocaml-3.10.0/hp/hp2ps/Main.h --- ocaml-3.10.0.old/hp/hp2ps/Main.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Main.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,74 @@ +#ifndef MAIN_H +#define MAIN_H + +#ifdef __STDC__ +#define PROTO(x) x +#else +#define PROTO(x) () +#endif + +/* our own ASSERT macro (for C) */ +#ifndef DEBUG +#define ASSERT(predicate) /*nothing*/ + +#else +void _ghcAssert PROTO((char *, unsigned int)); + +#define ASSERT(predicate) \ + if (predicate) \ + /*null*/; \ + else \ + _ghcAssert(__FILE__, __LINE__) +#endif + +/* partain: some ubiquitous types: floatish & intish. + Dubious to use float/int, but that is what it used to be... + (WDP 95/03) +*/ +typedef double floatish; +typedef double doublish; /* higher precision, if anything; little used */ +typedef int boolish; + +/* Use "long long" if we have it: the numbers in profiles can easily + * overflow 32 bits after a few seconds execution. + */ +#ifdef HAVE_LONG_LONG +typedef long long int intish; +#else +typedef long int intish; +#endif + +extern intish nsamples; +extern intish nmarks; +extern intish nidents; + +extern floatish maxcombinedheight; +extern floatish areabelow; +extern floatish epsfwidth; + +extern floatish xrange; +extern floatish yrange; + +extern floatish auxxrange; +extern floatish auxyrange; + +extern boolish eflag; +extern boolish gflag; +extern boolish yflag; +extern boolish bflag; +extern boolish sflag; +extern int mflag; +extern boolish tflag; +extern boolish cflag; + +extern char *programname; + +extern char *hpfile; +extern char *psfile; +extern char *auxfile; + +extern FILE *hpfp; +extern FILE *psfp; +extern FILE *auxfp; + +#endif /* MAIN_H */ diff -ruN ocaml-3.10.0.old/hp/hp2ps/Makefile ocaml-3.10.0/hp/hp2ps/Makefile --- ocaml-3.10.0.old/hp/hp2ps/Makefile 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Makefile 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,12 @@ +FILES=AreaBelow.c Curves.c Error.c Main.c Reorder.c TopTwenty.c \ + AuxFile.c Deviation.c HpFile.c Marks.c Scale.c TraceElement.c \ + Axes.c Dimensions.c Key.c PsFile.c Shade.c Utilities.c + +CFLAGS=-Wall + +../../hp2ps: $(FILES:.c=.o) + gcc -o ../../hp2ps -lm $(FILES:.c=.o) + +clean: + rm -f *.o ../../hp2ps + diff -ruN ocaml-3.10.0.old/hp/hp2ps/makefile.original ocaml-3.10.0/hp/hp2ps/makefile.original --- ocaml-3.10.0.old/hp/hp2ps/makefile.original 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/makefile.original 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,42 @@ +OBJS= \ + AuxFile.o \ + Axes.o \ + AreaBelow.o \ + Curves.o \ + Deviation.o \ + Dimensions.o \ + Error.o \ + HpFile.o \ + Key.o \ + Main.o \ + Marks.o \ + TopTwenty.o \ + TraceElement.o \ + PsFile.o \ + Reorder.o \ + Scale.o \ + Shade.o \ + Utilities.o + +# Please set MATHLIB and BIN appropriately. I don't need MATHLIB on my machine, +# but you may. + +MATHLIB = -lm + +DSTBIN = /n/Numbers/usr/lml/lml-0.997.4hp/sun3/bin + +CC= cc # gcc -Wall +CFLAGS= -g +LDFLAGS= ${STATICFLAG} + +TARGET=hp2ps + +${TARGET}: ${OBJS} + ${CC} -o ${TARGET} ${CCFLAGS} ${LDFLAGS} ${OBJS} ${MATHLIB} + +install: ${TARGET} + mv ${TARGET} ${DSTBIN}/${TARGET} + chmod 555 ${DSTBIN}/${TARGET} + +clean: + rm -f core *.o ${TARGET} diff -ruN ocaml-3.10.0.old/hp/hp2ps/Marks.c ocaml-3.10.0/hp/hp2ps/Marks.c --- ocaml-3.10.0.old/hp/hp2ps/Marks.c 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Marks.c 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,43 @@ +#include +#include "Main.h" +#include "Curves.h" +#include "Dimensions.h" +#include "HpFile.h" + +/* own stuff */ +#include "Marks.h" + +static void Caret PROTO((floatish, floatish, floatish)); + +void +Marks() +{ + intish i; + floatish m; + + for (i = 0; i < nmarks; i++) { + m = ((markmap[i] - samplemap[0]) / xrange) * graphwidth; + Caret(xpage(m), ypage(0.0), 4.0); + } +} + + +/* + * Draw a small white caret at (x,y) with width 2 * d + */ + +static void +Caret(x,y,d) + floatish x; floatish y; floatish d; +{ + fprintf(psfp, "%f %f moveto\n", x - d, y); + fprintf(psfp, "%f %f rlineto\n", d, -d); + fprintf(psfp, "%f %f rlineto\n", d, d); + fprintf(psfp, "closepath\n"); + + fprintf(psfp, "gsave\n"); + fprintf(psfp, "1.0 setgray\n"); + fprintf(psfp, "fill\n"); + fprintf(psfp, "grestore\n"); + fprintf(psfp, "stroke\n"); +} diff -ruN ocaml-3.10.0.old/hp/hp2ps/Marks.h ocaml-3.10.0/hp/hp2ps/Marks.h --- ocaml-3.10.0.old/hp/hp2ps/Marks.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Marks.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,6 @@ +#ifndef MARKS_H +#define MARKS_H + +void Marks PROTO((void)); + +#endif /* MARKS_H */ diff -ruN ocaml-3.10.0.old/hp/hp2ps/PsFile.c ocaml-3.10.0/hp/hp2ps/PsFile.c --- ocaml-3.10.0.old/hp/hp2ps/PsFile.c 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/PsFile.c 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,280 @@ +#include +#include +#include "Main.h" +#include "Defines.h" +#include "Dimensions.h" +#include "Curves.h" +#include "HpFile.h" +#include "Axes.h" +#include "Key.h" +#include "Marks.h" +#include "Utilities.h" + +/* own stuff */ +#include "PsFile.h" + +static void Prologue PROTO((void)); /* forward */ +static void Variables PROTO((void)); /* forward */ +static void BorderOutlineBox PROTO((void)); /* forward */ +static void BigTitleOutlineBox PROTO((void)); /* forward */ +static void TitleOutlineBox PROTO((void)); /* forward */ +static void BigTitleText PROTO((void)); /* forward */ +static void TitleText PROTO((void)); /* forward */ + +void +PutPsFile() +{ + Prologue(); + Variables(); + BorderOutlineBox(); + + if (bflag) { + BigTitleOutlineBox(); + BigTitleText(); + } else { + TitleOutlineBox(); + TitleText(); + } + + CurvesInit(); + + Axes(); + + if (TWENTY) Key(); + + Curves(); + + if (!yflag) Marks(); + + fprintf(psfp, "showpage\n"); +} + + +static void StandardSpecialComments PROTO((void)); /* forward */ +static void EPSFSpecialComments PROTO((floatish)); /* forward */ +static void Landscape PROTO((void)); /* forward */ +static void Portrait PROTO((void)); /* forward */ +static void Scaling PROTO((floatish)); /* forward */ + +static void +Prologue() +{ + if (eflag) { + floatish epsfscale = epsfwidth / (floatish) borderwidth; + EPSFSpecialComments(epsfscale); + Scaling(epsfscale); + } else { + StandardSpecialComments(); + if (gflag) Portrait(); else Landscape(); + } +} + +extern char *jobstring; +extern char *datestring; + +static void +StandardSpecialComments() +{ + fprintf(psfp, "%%!PS-Adobe-2.0\n"); + fprintf(psfp, "%%%%Title: %s\n", jobstring); + fprintf(psfp, "%%%%Creator: %s (version %s)\n", programname, VERSION); + fprintf(psfp, "%%%%CreationDate: %s\n", datestring); + fprintf(psfp, "%%%%EndComments\n"); +} + +static void +EPSFSpecialComments(epsfscale) + floatish epsfscale; +{ + fprintf(psfp, "%%!PS-Adobe-2.0\n"); + fprintf(psfp, "%%%%Title: %s\n", jobstring); + fprintf(psfp, "%%%%Creator: %s (version %s)\n", programname, VERSION); + fprintf(psfp, "%%%%CreationDate: %s\n", datestring); + fprintf(psfp, "%%%%BoundingBox: 0 0 %d %d\n", + (int) (borderwidth * epsfscale + 0.5), + (int) (borderheight * epsfscale + 0.5) ); + fprintf(psfp, "%%%%EndComments\n"); +} + + + +static void +Landscape() +{ + fprintf(psfp, "-90 rotate\n"); + fprintf(psfp, "%f %f translate\n", -(borderwidth + (floatish) START_Y), + (floatish) START_X); +} + +static void +Portrait() +{ + fprintf(psfp, "%f %f translate\n", (floatish) START_X, (floatish) START_Y); +} + +static void +Scaling(epsfscale) + floatish epsfscale; +{ + fprintf(psfp, "%f %f scale\n", epsfscale, epsfscale); +} + + +static void +Variables() +{ + fprintf(psfp, "/HE%d /Helvetica findfont %d scalefont def\n", + NORMAL_FONT, NORMAL_FONT); + + fprintf(psfp, "/HE%d /Helvetica findfont %d scalefont def\n", + LARGE_FONT, LARGE_FONT); +} + + +static void +BorderOutlineBox() +{ + fprintf(psfp, "newpath\n"); + fprintf(psfp, "0 0 moveto\n"); + fprintf(psfp, "0 %f rlineto\n", borderheight); + fprintf(psfp, "%f 0 rlineto\n", borderwidth); + fprintf(psfp, "0 %f rlineto\n", -borderheight); + fprintf(psfp, "closepath\n"); + fprintf(psfp, "%f setlinewidth\n", borderthick); + fprintf(psfp, "stroke\n"); +} + +static void +BigTitleOutlineBox() +{ + fprintf(psfp, "newpath\n"); + fprintf(psfp, "%f %f moveto\n", borderspace, + borderheight - titleheight - borderspace); + fprintf(psfp, "0 %f rlineto\n", titleheight); + fprintf(psfp, "%f 0 rlineto\n", titlewidth); + fprintf(psfp, "0 %f rlineto\n", -titleheight); + fprintf(psfp, "closepath\n"); + fprintf(psfp, "%f setlinewidth\n", borderthick); + fprintf(psfp, "stroke\n"); + + fprintf(psfp, "%f %f moveto\n", borderspace, + borderheight - titleheight / 2 - borderspace); + fprintf(psfp, "%f 0 rlineto\n", titlewidth); + fprintf(psfp, "stroke\n"); +} + + +static void +TitleOutlineBox() +{ + fprintf(psfp, "newpath\n"); + fprintf(psfp, "%f %f moveto\n", borderspace, + borderheight - titleheight - borderspace); + fprintf(psfp, "0 %f rlineto\n", titleheight); + fprintf(psfp, "%f 0 rlineto\n", titlewidth); + fprintf(psfp, "0 %f rlineto\n", -titleheight); + fprintf(psfp, "closepath\n"); + fprintf(psfp, "%f setlinewidth\n", borderthick); + fprintf(psfp, "stroke\n"); +} + +static void EscapePrint PROTO((char *, int)); /* forward */ + +static void +BigTitleText() +{ + floatish x, y; + + x = borderspace + titletextspace; + y = borderheight - titleheight / 2 - borderspace + titletextspace; + + /* job identifier goes on top at the far left */ + + fprintf(psfp, "HE%d setfont\n", TITLE_TEXT_FONT); + fprintf(psfp, "%f %f moveto\n", x, y); + fputc('(', psfp); + EscapePrint(jobstring, BIG_JOB_STRING_WIDTH); + fprintf(psfp, ") show\n"); + + y = borderheight - titleheight - borderspace + titletextspace; + + /* area below curve gows at the botton, far left */ + + fprintf(psfp, "HE%d setfont\n", TITLE_TEXT_FONT); + fprintf(psfp, "%f %f moveto\n", x, y); + fputc('(', psfp); + CommaPrint(psfp, (intish)areabelow); + fprintf(psfp, " %s x %s)\n", valueunitstring, sampleunitstring); + fprintf(psfp, "show\n"); + + /* date goes at far right */ + + fprintf(psfp, "HE%d setfont\n", TITLE_TEXT_FONT); + fprintf(psfp, "(%s)\n", datestring); + fprintf(psfp, "dup stringwidth pop\n"); + fprintf(psfp, "%f\n", (titlewidth + borderspace) - titletextspace); + fprintf(psfp, "exch sub\n"); + fprintf(psfp, "%f moveto\n", y); + fprintf(psfp, "show\n"); +} + + +static void +TitleText() +{ + floatish x, y; + + x = borderspace + titletextspace; + y = borderheight - titleheight - borderspace + titletextspace; + + /* job identifier goes at far left */ + + fprintf(psfp, "HE%d setfont\n", TITLE_TEXT_FONT); + fprintf(psfp, "%f %f moveto\n", x, y); + fputc('(', psfp); + EscapePrint(jobstring, SMALL_JOB_STRING_WIDTH); + fprintf(psfp, ") show\n"); + + /* area below curve is centered */ + + fprintf(psfp, "HE%d setfont\n", TITLE_TEXT_FONT); + fputc('(', psfp); + CommaPrint(psfp, (intish) areabelow); + fprintf(psfp, " %s x %s)\n", valueunitstring, sampleunitstring); + + fprintf(psfp, "dup stringwidth pop\n"); + fprintf(psfp, "2 div\n"); + fprintf(psfp, "%f\n", titlewidth / 2); + fprintf(psfp, "exch sub\n"); + fprintf(psfp, "%f moveto\n", y); + fprintf(psfp, "show\n"); + + /* date goes at far right */ + + fprintf(psfp, "HE%d setfont\n", TITLE_TEXT_FONT); + fprintf(psfp, "(%s)\n", datestring); + fprintf(psfp, "dup stringwidth pop\n"); + fprintf(psfp, "%f\n", (titlewidth + borderspace) - titletextspace); + fprintf(psfp, "exch sub\n"); + fprintf(psfp, "%f moveto\n", y); + fprintf(psfp, "show\n"); +} + +/* + * Print a string s in width w, escaping characters where necessary. + */ + +static void +EscapePrint(s,w) + char* s; int w; +{ + for ( ; *s && w > 0; s++, w--) { + if (*s == '(') { /* escape required */ + fputc('\\', psfp); + } else if (*s == ')') { + fputc('\\', psfp); + } + + fputc(*s, psfp); + } +} diff -ruN ocaml-3.10.0.old/hp/hp2ps/PsFile.h ocaml-3.10.0/hp/hp2ps/PsFile.h --- ocaml-3.10.0.old/hp/hp2ps/PsFile.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/PsFile.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,6 @@ +#ifndef PS_FILE_H +#define PS_FILE_H + +void PutPsFile PROTO((void)); + +#endif /* PS_FILE_H */ diff -ruN ocaml-3.10.0.old/hp/hp2ps/README.GHC ocaml-3.10.0/hp/hp2ps/README.GHC --- ocaml-3.10.0.old/hp/hp2ps/README.GHC 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/README.GHC 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,4 @@ +This "hp2ps" program was written and is maintained by Dave Wakeling at +York. All I (WDP) have done is make it slot into the "make world"ery. + +We are grateful for this contribution of shared code. diff -ruN ocaml-3.10.0.old/hp/hp2ps/Reorder.c ocaml-3.10.0/hp/hp2ps/Reorder.c --- ocaml-3.10.0.old/hp/hp2ps/Reorder.c 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Reorder.c 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,89 @@ +#include +#include +#include +#include "Main.h" +#include "Defines.h" +#include "Error.h" +#include "HpFile.h" +#include "Utilities.h" + +/* own stuff */ +#include "Reorder.h" + +static struct order { + char* ident; + int order; +} *ordermap = 0; + +static int ordermapmax = 0; +static int ordermapindex = 0; + + +void +OrderFor(ident, order) + char* ident; + int order; +{ + if (! ordermap) { + ordermapmax = (nidents > TWENTY ? nidents : TWENTY) * 2; + /* Assume nidents read is indication of the No of + idents in the .aux file (*2 for good luck !) */ + ordermap = xmalloc(ordermapmax * sizeof(struct order)); + } + + if (ordermapindex < ordermapmax) { + ordermap[ ordermapindex ].ident = copystring(ident); + ordermap[ ordermapindex ].order = order; + ordermapindex++; + } else { + Disaster("order map overflow"); + } +} + +/* + * Get the order of to be used for "ident" if there is one. + * Otherwise, return 0 which is the minimum ordering value. + */ + +int +OrderOf(ident) + char* ident; +{ + int i; + + for (i = 0; i < ordermapindex; i++) { + if (strcmp(ordermap[i].ident, ident) == 0) { /* got it */ + return(ordermap[i].order); + } + } + + return 0; +} + +/* + * Reorder on the basis of information from ".aux" file. + */ + +void +Reorder() +{ + intish i; + intish j; + int min; + struct entry* e; + int o1, o2; + + for (i = 0; i < nidents-1; i++) { + min = i; + for (j = i+1; j < nidents; j++) { + o1 = OrderOf(identtable[ j ]->name); + o2 = OrderOf(identtable[ min ]->name); + + if (o1 < o2 ) min = j; + } + + e = identtable[ min ]; + identtable[ min ] = identtable[ i ]; + identtable[ i ] = e; + } +} diff -ruN ocaml-3.10.0.old/hp/hp2ps/Reorder.h ocaml-3.10.0/hp/hp2ps/Reorder.h --- ocaml-3.10.0.old/hp/hp2ps/Reorder.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Reorder.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,8 @@ +#ifndef REORDER_H +#define REORDER_H + +void Reorder PROTO((void)); +int OrderOf PROTO((char *)); +void OrderFor PROTO((char *, int)); + +#endif /* REORDER_H */ diff -ruN ocaml-3.10.0.old/hp/hp2ps/sample.aux ocaml-3.10.0/hp/hp2ps/sample.aux --- ocaml-3.10.0.old/hp/hp2ps/sample.aux 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/sample.aux 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,6 @@ +X_RANGE 30.23 +Y_RANGE 8.00 +ORDER toto 1 +ORDER tata 2 +SHADE toto 0.00 +SHADE tata 0.20 diff -ruN ocaml-3.10.0.old/hp/hp2ps/sample.hp ocaml-3.10.0/hp/hp2ps/sample.hp --- ocaml-3.10.0.old/hp/hp2ps/sample.hp 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/sample.hp 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,17 @@ +JOB "FOO -hC" +DATE "Thu Dec 26 18:17 2002" +SAMPLE_UNIT "seconds" +VALUE_UNIT "bytes" +BEGIN_SAMPLE 0.00 +toto 4 +tata 4 +END_SAMPLE 0.00 +BEGIN_SAMPLE 15.07 +toto 1 +tata 2 +END_SAMPLE 15.07 +BEGIN_SAMPLE 30.23 +toto 2 +tata 3 +END_SAMPLE 30.23 + diff -ruN ocaml-3.10.0.old/hp/hp2ps/sample.ps ocaml-3.10.0/hp/hp2ps/sample.ps --- ocaml-3.10.0.old/hp/hp2ps/sample.ps 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/sample.ps 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,237 @@ +%!PS-Adobe-2.0 +%%Title: FOO -hC +%%Creator: hp2ps (version 0.25) +%%CreationDate: Thu Dec 26 18:17 2002 +%%EndComments +-90 rotate +-756.000000 72.000000 translate +/HE10 /Helvetica findfont 10 scalefont def +/HE12 /Helvetica findfont 12 scalefont def +newpath +0 0 moveto +0 432.000000 rlineto +648.000000 0 rlineto +0 -432.000000 rlineto +closepath +0.500000 setlinewidth +stroke +newpath +5.000000 407.000000 moveto +0 20.000000 rlineto +638.000000 0 rlineto +0 -20.000000 rlineto +closepath +0.500000 setlinewidth +stroke +HE12 setfont +11.000000 413.000000 moveto +(FOO -hC) show +HE12 setfont +(143 bytes x seconds) +dup stringwidth pop +2 div +319.000000 +exch sub +413.000000 moveto +show +HE12 setfont +(Thu Dec 26 18:17 2002) +dup stringwidth pop +637.000000 +exch sub +413.000000 moveto +show +45.000000 20.000000 moveto +546.992124 0 rlineto +0.500000 setlinewidth +stroke +HE10 setfont +(seconds) +dup stringwidth pop +591.992124 +exch sub +5.000000 moveto +show +45.000000 20.000000 moveto +0 -4 rlineto +stroke +HE10 setfont +(0.0) +dup stringwidth pop +2 div +45.000000 exch sub +5.000000 moveto +show +135.471737 20.000000 moveto +0 -4 rlineto +stroke +HE10 setfont +(5.0) +dup stringwidth pop +2 div +135.471737 exch sub +5.000000 moveto +show +225.943475 20.000000 moveto +0 -4 rlineto +stroke +HE10 setfont +(10.0) +dup stringwidth pop +2 div +225.943475 exch sub +5.000000 moveto +show +316.415212 20.000000 moveto +0 -4 rlineto +stroke +HE10 setfont +(15.0) +dup stringwidth pop +2 div +316.415212 exch sub +5.000000 moveto +show +406.886949 20.000000 moveto +0 -4 rlineto +stroke +HE10 setfont +(20.0) +dup stringwidth pop +2 div +406.886949 exch sub +5.000000 moveto +show +497.358687 20.000000 moveto +0 -4 rlineto +stroke +HE10 setfont +(25.0) +dup stringwidth pop +2 div +497.358687 exch sub +5.000000 moveto +show +45.000000 20.000000 moveto +0 382.000000 rlineto +0.500000 setlinewidth +stroke +gsave +HE10 setfont +(bytes) +dup stringwidth pop +402.000000 +exch sub +40.000000 exch +translate +90 rotate +0 0 moveto +show +grestore +45.000000 20.000000 moveto +-4 0 rlineto +stroke +HE10 setfont +(0) +dup stringwidth +2 div +20.000000 exch sub +exch +40.000000 exch sub +exch +moveto +show +45.000000 115.500000 moveto +-4 0 rlineto +stroke +HE10 setfont +(2) +dup stringwidth +2 div +115.500000 exch sub +exch +40.000000 exch sub +exch +moveto +show +45.000000 211.000000 moveto +-4 0 rlineto +stroke +HE10 setfont +(4) +dup stringwidth +2 div +211.000000 exch sub +exch +40.000000 exch sub +exch +moveto +show +45.000000 306.500000 moveto +-4 0 rlineto +stroke +HE10 setfont +(6) +dup stringwidth +2 div +306.500000 exch sub +exch +40.000000 exch sub +exch +moveto +show +596.992124 140.333333 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.000000 setgray +fill +grestore +stroke +HE10 setfont +615.992124 142.333333 moveto +(toto) show +596.992124 267.666667 moveto +0 14 rlineto +14 0 rlineto +0 -14 rlineto +closepath +gsave +0.200000 setgray +fill +grestore +stroke +HE10 setfont +615.992124 269.666667 moveto +(tata) show +45.000000 20.000000 moveto +45.000000 20.000000 lineto +317.681816 20.000000 lineto +591.992124 20.000000 lineto +591.992124 115.500000 lineto +591.992124 115.500000 lineto +317.681816 67.750000 lineto +45.000000 211.000000 lineto +closepath +gsave +0.000000 setgray +fill +grestore +stroke +45.000000 211.000000 moveto +45.000000 211.000000 lineto +317.681816 67.750000 lineto +591.992124 115.500000 lineto +591.992124 258.750000 lineto +591.992124 258.750000 lineto +317.681816 163.250000 lineto +45.000000 402.000000 lineto +closepath +gsave +0.200000 setgray +fill +grestore +stroke +showpage diff -ruN ocaml-3.10.0.old/hp/hp2ps/Scale.c ocaml-3.10.0/hp/hp2ps/Scale.c --- ocaml-3.10.0.old/hp/hp2ps/Scale.c 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Scale.c 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,87 @@ +#include +#include "Main.h" +#include "Defines.h" +#include "Dimensions.h" +#include "Error.h" +#include "HpFile.h" +#include "Utilities.h" + +/* own stuff */ +#include "Scale.h" + +/* + * Return the maximum combined height that all the sample + * curves will reach. This (absolute) figure can then be + * used to scale the samples automatically so that they + * fit on the page. + */ + +extern void free(); + +floatish +MaxCombinedHeight() +{ + intish i; + intish j; + floatish mx; + int bucket; + floatish value; + struct chunk* ch; + floatish *maxima; + + maxima = (floatish*) xmalloc(nsamples * sizeof(floatish)); + for (i = 0; i < nsamples; i++) { + maxima[ i ] = 0.0; + } + + for (i = 0; i < nidents; i++) { + for (ch = identtable[i]->chk; ch; ch = ch->next) { + for (j = 0; j < ch->nd; j++) { + bucket = ch->d[j].bucket; + value = ch->d[j].value; + if (bucket >= nsamples) + Disaster("bucket out of range"); + maxima[ bucket ] += value; + } + } + } + + for (mx = maxima[ 0 ], i = 0; i < nsamples; i++) { + if (maxima[ i ] > mx) mx = maxima[ i ]; + } + + free(maxima); + return mx; +} + + + +/* + * Scale the values from the samples so that they will fit on + * the page. + */ + +extern floatish xrange; +extern floatish yrange; + +void +Scale() +{ + intish i; + intish j; + floatish sf; + struct chunk* ch; + + if (yrange == 0.0) /* no samples */ + return; + + sf = graphheight / yrange; + + for (i = 0; i < nidents; i++) { + for (ch = identtable[i]->chk; ch; ch = ch->next) { + for (j = 0; j < ch->nd; j++) { + ch->d[j].value = ch->d[j].value * sf; + } + } + } +} diff -ruN ocaml-3.10.0.old/hp/hp2ps/Scale.h ocaml-3.10.0/hp/hp2ps/Scale.h --- ocaml-3.10.0.old/hp/hp2ps/Scale.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Scale.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,7 @@ +#ifndef SCALE_H +#define SCALE_H + +floatish MaxCombinedHeight PROTO((void)); +void Scale PROTO((void)); + +#endif /* SCALE_H */ diff -ruN ocaml-3.10.0.old/hp/hp2ps/Shade.c ocaml-3.10.0/hp/hp2ps/Shade.c --- ocaml-3.10.0.old/hp/hp2ps/Shade.c 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Shade.c 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,130 @@ +#include +#include +#include +#include "Main.h" +#include "Defines.h" +#include "Error.h" +#include "Utilities.h" + +/* own stuff */ +#include "Shade.h" + +static struct shade { + char* ident; + floatish shade; +} *shademap; + +static int shademapmax = 0; +static int shademapindex = 0; + +/* + * Set the shade to be used for "ident" to "shade". + */ + +void +ShadeFor(ident, shade) + char* ident; + floatish shade; +{ + if (! shademap) { + shademapmax = (nidents > TWENTY ? nidents : TWENTY) * 2; + /* Assume nidents read is indication of the No of + idents in the .aux file (*2 for good luck) */ + /* NB *2 is needed as .aux and .hp elements may differ */ + shademap = xmalloc(shademapmax * sizeof(struct shade)); + } + + if (shademapindex < shademapmax) { + shademap[ shademapindex ].ident = copystring(ident); + shademap[ shademapindex ].shade = shade; + shademapindex++; + } else { + Disaster("shade map overflow"); + } +} + +/* + * Get the shade to be used for "ident" if there is one. + * Otherwise, think of a new one. + */ + +static floatish ThinkOfAShade PROTO((void)); /* forward */ + +floatish +ShadeOf(ident) + char* ident; +{ + int i; + floatish shade; + + for (i = 0; i < shademapindex; i++) { + if (strcmp(shademap[i].ident, ident) == 0) { /* got it */ + return(shademap[i].shade); + } + } + + shade = ThinkOfAShade(); + + ShadeFor(ident, shade); + + return shade; +} + + + +#define N_MONO_SHADES 10 + +static floatish m_shades[ N_MONO_SHADES ] = { + 0.00000, 0.20000, 0.60000, 0.30000, 0.90000, + 0.40000, 1.00000, 0.70000, 0.50000, 0.80000 +}; + +#define N_COLOUR_SHADES 27 + +/* HACK: 0.100505 means 100% red, 50% green, 50% blue */ + +static floatish c_shades[ N_COLOUR_SHADES ] = { + 0.000000, 0.000010, 0.001000, 0.001010, 0.100000, + 0.100010, 0.101000, 0.101010, 0.000005, 0.000500, + 0.000510, 0.001005, 0.050000, 0.050010, 0.051000, + 0.051010, 0.100005, 0.100500, 0.100510, 0.101005, + 0.000505, 0.050005, 0.050500, 0.050510, 0.051005, + 0.100505, 0.050505 +}; + +static floatish +ThinkOfAShade() +{ + static int thisshade = -1; + + thisshade++; + return cflag ? + c_shades[ thisshade % N_COLOUR_SHADES ] : + m_shades[ thisshade % N_MONO_SHADES ] ; +} + +static floatish +extract_colour(shade,factor) + floatish shade; + intish factor; +{ + intish i,j; + + i = (int)(shade * factor); + j = i / 100; + return (i - j * 100) / 10.0; +} + +void +SetPSColour(shade) + floatish shade; +{ + if (cflag) { + fprintf(psfp, "%f %f %f setrgbcolor\n", + extract_colour(shade, (intish)100), + extract_colour(shade, (intish)10000), + extract_colour(shade, (intish)1000000)); + } else { + fprintf(psfp, "%f setgray\n", shade); + } +} diff -ruN ocaml-3.10.0.old/hp/hp2ps/Shade.h ocaml-3.10.0/hp/hp2ps/Shade.h --- ocaml-3.10.0.old/hp/hp2ps/Shade.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Shade.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,8 @@ +#ifndef SHADE_H +#define SHADE_H + +floatish ShadeOf PROTO((char *)); +void ShadeFor PROTO((char *, floatish)); +void SetPSColour PROTO((floatish)); + +#endif /* SHADE_H */ diff -ruN ocaml-3.10.0.old/hp/hp2ps/TopTwenty.c ocaml-3.10.0/hp/hp2ps/TopTwenty.c --- ocaml-3.10.0.old/hp/hp2ps/TopTwenty.c 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/TopTwenty.c 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,73 @@ +#include +#include "Main.h" +#include "Defines.h" +#include "Error.h" +#include "HpFile.h" +#include "Utilities.h" + +/* own stuff */ +#include "TopTwenty.h" + +/* + * We only have room in the key for a maximum of 20 identifiers. + * We therefore choose to keep the top 20 bands --- these will + * be the most important ones, since this pass is performed after + * the threshold and standard deviation passes. If there are more + * than 20 bands, the excess are gathered together as an "OTHER" ] + * band which appears as band 20. + */ + +extern void free(); + +void +TopTwenty() +{ + intish i; + intish j; + intish compact; + intish bucket; + floatish value; + struct entry* en; + struct chunk* ch; + floatish *other; + + i = nidents; + if (i <= TWENTY) return; /* nothing to do! */ + + other = (floatish*) xmalloc(nsamples * sizeof(floatish)); + /* build a list of samples for "OTHER" */ + + compact = (i - TWENTY) + 1; + + for (i = 0; i < nsamples; i++) { + other[ i ] = 0.0; + } + + for (i = 0; i < compact && i < nidents; i++) { + for (ch = identtable[i]->chk; ch; ch = ch->next) { + for (j = 0; j < ch->nd; j++) { + bucket = ch->d[j].bucket; + value = ch->d[j].value; + if (bucket >= nsamples) + Disaster("bucket out of range"); + other[ bucket ] += value; + } + } + } + + en = MakeEntry("OTHER"); + en->next = 0; + + for (i = 0; i < nsamples; i++) { + StoreSample(en, i, other[i]); + } + + /* slide samples down */ + for (i = compact; i < nidents; i++) { + identtable[i-compact+1] = identtable[i]; + } + + nidents = TWENTY; + identtable[0] = en; + free(other); +} diff -ruN ocaml-3.10.0.old/hp/hp2ps/TopTwenty.h ocaml-3.10.0/hp/hp2ps/TopTwenty.h --- ocaml-3.10.0.old/hp/hp2ps/TopTwenty.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/TopTwenty.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,6 @@ +#ifndef TOP_TWENTY_H +#define TOP_TWENTY_H + +void TopTwenty PROTO((void)); + +#endif /* TOP_TWENTY_H */ diff -ruN ocaml-3.10.0.old/hp/hp2ps/TraceElement.c ocaml-3.10.0/hp/hp2ps/TraceElement.c --- ocaml-3.10.0.old/hp/hp2ps/TraceElement.c 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/TraceElement.c 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,97 @@ +#include +#include "Main.h" +#include "Defines.h" +#include "HpFile.h" +#include "Error.h" +#include "Utilities.h" + +/* own stuff */ +#include "TraceElement.h" + +/* + * Compute the total volume for each identifier, and the grand + * total of these totals. The identifiers whose totals when + * added together amount to less that a threshold percentage + * (default 1%) of the grand total are considered to be ``trace + * elements'' and they are thrown away. + */ + +extern void free(); + +extern floatish thresholdpercent; + +void TraceElement() +{ + intish i; + intish j; + struct chunk* ch; + floatish grandtotal; + intish min; + floatish t; + floatish p; + struct entry* e; + intish *totals; + + totals = (intish *) xmalloc(nidents * sizeof(intish)); + + /* find totals */ + + for (i = 0; i < nidents; i++) { + totals[ i ] = 0; + } + + for (i = 0; i < nidents; i++) { + for (ch = identtable[i]->chk; ch; ch = ch->next) { + for (j = 0; j < ch->nd; j++) { + totals[ i ] += ch->d[j].value; + } + } + } + + /* sort on the basis of total */ + + for (i = 0; i < nidents-1; i++) { + min = i; + for (j = i+1; j < nidents; j++) { + if (totals[ j ] < totals[ min ]) { + min = j; + } + } + + t = totals[ min ]; + totals[ min ] = totals[ i ]; + totals[ i ] = t; + + e = identtable[ min ]; + identtable[ min ] = identtable[ i ]; + identtable[ i ] = e; + } + + + /* find the grand total (NB: can get *BIG*!) */ + + grandtotal = 0.0; + + for (i = 0; i < nidents; i++) { + grandtotal += (floatish) totals[ i ]; + } + + t = 0.0; /* cumulative percentage */ + + for (i = 0; i < nidents; i++) { + p = (100.0 * (floatish) totals[i]) / grandtotal; + t = t + p; + if (t >= THRESHOLD_PERCENT) { + break; + } + } + + /* identifiers from 0 to i-1 should be removed */ + for (j = 0; i < nidents; i++, j++) { + identtable[j] = identtable[i]; + } + + nidents = j; + + free(totals); +} diff -ruN ocaml-3.10.0.old/hp/hp2ps/TraceElement.h ocaml-3.10.0/hp/hp2ps/TraceElement.h --- ocaml-3.10.0.old/hp/hp2ps/TraceElement.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/TraceElement.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,6 @@ +#ifndef TRACE_ELEMENT_H +#define TRACE_ELEMENT_H + +void TraceElement PROTO((void)); + +#endif /* TRACE_ELEMENT_H */ diff -ruN ocaml-3.10.0.old/hp/hp2ps/Utilities.c ocaml-3.10.0/hp/hp2ps/Utilities.c --- ocaml-3.10.0.old/hp/hp2ps/Utilities.c 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Utilities.c 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,132 @@ +#include +#include +#include "Main.h" +#include "Error.h" + +extern void* malloc(); + +char* +Basename(name) + char* name; +{ + char* t; + + t = name; + + while (*name) { + if (*name == '/') { + t = name+1; + } + name++; + } + + return t; +} + +void +DropSuffix(name, suffix) + char* name; char* suffix; +{ + char* t; + + t = (char*) 0; + + while (*name) { + if (*name == '.') { + t = name; + } + name++; + } + + if (t != (char*) 0 && strcmp(t, suffix) == 0) { + *t = '\0'; + } +} + +FILE* +OpenFile(s, mode) + char* s; char* mode; +{ + FILE* r; + + if ((r = fopen(s, mode)) == NULL) { + /*NOTREACHED*/ + Error("cannot open %s", s); + } + + return r; +} + + +#define ONETHOUSAND 1000 + +/* + * Print a positive integer with commas + */ + +void +CommaPrint(fp,n) + FILE* fp; + intish n; +{ + if (n < ONETHOUSAND) { + fprintf(fp, "%d", (int)n); + } else { + CommaPrint(fp, n / ONETHOUSAND); + fprintf(fp, ",%03d", (int)n % ONETHOUSAND); + } +} + +void * +xmalloc(n) + int n; +{ + void *r; + + r = (void*) malloc(n); + if (!r) { + /*NOTREACHED*/ + Disaster("%s, sorry, out of memory", hpfile); + } + return r; +} + +void * +xrealloc(p, n) + void *p; + int n; +{ + void *r; + extern void *realloc(); + + r = realloc(p, n); + if (!r) { + /*NOTREACHED*/ + Disaster("%s, sorry, out of memory", hpfile); + } + return r; +} + +char * +copystring(s) + char *s; +{ + char *r; + + r = (char*) xmalloc(strlen(s)+1); + strcpy(r, s); + return r; +} + +char * +copystring2(s, t) + char *s, *t; +{ + char *r; + + r = (char*) xmalloc(strlen(s)+strlen(t)+1); + strcpy(r, s); + strcat(r, t); + return r; +} + diff -ruN ocaml-3.10.0.old/hp/hp2ps/Utilities.h ocaml-3.10.0/hp/hp2ps/Utilities.h --- ocaml-3.10.0.old/hp/hp2ps/Utilities.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hp2ps/Utilities.h 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,13 @@ +#ifndef UTILITIES_H +#define UTILITIES_H + +char* Basename PROTO((char *)); +void DropSuffix PROTO((char *, char *)); +FILE* OpenFile PROTO((char *, char *)); +void CommaPrint PROTO((FILE *, intish)); +char *copystring PROTO((char *)); +char *copystring2 PROTO((char *, char *)); +void *xmalloc PROTO((int)); +void *xrealloc PROTO((void *, int)); + +#endif /* UTILITIES_H */ diff -ruN ocaml-3.10.0.old/hp/hPCompute.ml ocaml-3.10.0/hp/hPCompute.ml --- ocaml-3.10.0.old/hp/hPCompute.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hPCompute.ml 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,665 @@ +open Typeopt +open HPTypes +open HPGlobals + +(* TODO: + +Some simple computations: +* Repartition of blocks per size +* Repartition of blocks per tag +* Repartition of blocks per path +* Repartition of memory per root + +*) + + +(*************************************************************************) +(* *) +(* compute_memory_per_module *) +(* *) +(*************************************************************************) + +let compute_memory_per_module hp = + let h = hp.hp_info in + let modules = ref [] in + for i = 0 to Array.length h.caml_globals -1 do + let name = h.globals_map.(i) in + let pointer = h.caml_globals.(i) in + let mem = HPScanHeap.scan hp pointer in + modules := (mem, name) :: !modules + done; + + let modules = List.sort (fun (m1,_) (m2,_) -> compare m2 m1) !modules in + + + print_newline (); + Printf.printf "----------------------------------"; + print_newline (); + + Printf.printf "Modules: %d modules" (List.length modules); print_newline (); + List.iter (fun (mem, name) -> + Printf.printf "%7d %s\n" mem name; + ) modules; + modules + +(*************************************************************************) +(* *) +(* compute_memory_per_root *) +(* *) +(*************************************************************************) + +let compute_memory_per_root hp = + + let roots = ref [] in + + + print_newline (); + Printf.printf "----------------------------------"; + print_newline (); + let h = hp.hp_info in + for i = 0 to Array.length h.caml_globals -1 do + let name = h.globals_map.(i) in + let pointer = h.caml_globals.(i) in + let b = hp.hp_blocks.(pointer) in + let info = h.mem_repr.(i).global_names in + Printf.printf "%-20s : \n" name; + for j = 0 to (min (Array.length info) (Array.length b.block_content)) + - 1 do + let mem = HPScanHeap.scan hp b.block_content.(j) in + let root = info.(j) in + Printf.printf " %-40s %d\n" root mem; + if mem > 0 && root <> "-" then + roots := (mem, Printf.sprintf "%s.%s" name root) :: !roots + done; + print_newline (); + done; + + + let roots = List.sort (fun (m1,_) (m2,_) -> compare m2 m1) !roots in + + print_newline (); + Printf.printf "----------------------------------"; + print_newline (); + + Printf.printf "Roots:"; print_newline (); + List.iter (fun (mem, name) -> + Printf.printf "%7d %s\n" mem name; + ) roots; + roots + + + +(*************************************************************************) +(* *) +(* a *) +(* *) +(*************************************************************************) + +let close_graph hp = + + Printf.printf "Closing graph..."; print_newline (); + + for p1 = 2 to Array.length hp.hp_blocks - 1 do + + let b1 = hp.hp_blocks.(p1) in + for i = 0 to Array.length b1.block_content - 1 do + let p2 = b1.block_content.(i) in + if p2 > 1 then + let b2 = hp.hp_blocks.(p2) in + b2.block_reverse <- p1 :: b2.block_reverse + done + + done; + + Printf.printf "Graph closed."; print_newline (); + () + +(*************************************************************************) +(* *) +(* parse_repr *) +(* *) +(*************************************************************************) + +let dummy_block = { + repr_tag = None; + repr_size = None; + repr_content = None; + repr_labels = None; + } + +let parse_repr hp = + let h = hp.hp_info in + let paths = Hashtbl.create 111 in + + Array.iter (fun m -> + Hashtbl.iter (fun path rr -> + try + let rr' = Hashtbl.find paths rr.repr_path in + if rr'.repr_level < rr.repr_level then begin + rr'.repr_level <- rr.repr_level; + rr'.repr_repr <- rr.repr_repr + end + with Not_found -> + Hashtbl.add paths rr.repr_path rr; + rr.repr_repr <- rr.repr_repr; + ) m.representations + ) h.mem_repr; + + (* + Hashtbl.iter (fun path rr -> + print_representation paths rr + ) paths; +*) + + let objects = Hashtbl.create 111 in + let equiv = ref [] in + let reprs = Hashtbl.create 111 in + + List.iter (fun (tag, name) -> + + let repr = + Repr_block { dummy_block with repr_tag = Some tag } in + let rec r = { + repr_path = name (*Path.Pident (Ident.create name) *); + repr_repr = repr; + repr_level = 6; + } in + + Hashtbl.add objects (tag, None) (ref [r]); + Hashtbl.add paths r.repr_path r; + Hashtbl.add reprs r.repr_repr r.repr_path + ) [ + Obj.closure_tag, "closure"; + Obj.double_array_tag, "double_array"; + Obj.custom_tag, "custom"; + Obj.double_tag, "float"; + Obj.abstract_tag, "abstract"; + Obj.lazy_tag, "lazy"; + Obj.object_tag, "object"; + ]; + + let rec insert_path path r = + match r with + Repr_block b -> + begin + match b.repr_tag with + None -> () + | Some tag when tag <> Obj.string_tag && + (tag = 0 || tag >= Obj.no_scan_tag) -> () + | Some tag -> + let key = (tag, b.repr_size) in + try + let list = Hashtbl.find objects key in +(* + Printf.printf "Adding %s with tag %d" + (Path.name path.repr_path) tag; print_newline (); *) + list := path :: !list + with Not_found -> + (* + Printf.printf "Insert %s with tag %d" + (Path.name path.repr_path) tag; print_newline (); *) + Hashtbl.add objects key (ref [path]) + end + | Repr_path (args, rr) -> () + | Repr_integer -> () + | Repr_choice list -> + List.iter (fun (name, r) -> insert_path path r) list + | Repr_unknown -> () + | Repr_variable i -> () + in + + Hashtbl.iter (fun path rr -> + try + let path = Hashtbl.find reprs rr.repr_repr in + equiv := (path, rr.repr_path) :: !equiv + with _ -> + Hashtbl.add reprs rr.repr_repr rr.repr_path; +(* if Path.name rr.repr_path = "CommonTypes.gui_result_handler" then begin + Printf.printf "Re-adding closure !!"; print_newline (); + print_representation paths rr; + print_newline (); + end; *) + insert_path rr rr.repr_repr + ) paths; + + if arg_verbose_types () then begin + + List.iter (fun (p1,p2) -> + Printf.printf "Equivalent types: %s and %s" + ( (*Path.name*) p1) ( (*Path.name*) p2); print_newline (); + ) !equiv; + + Hashtbl.iter (fun (tag, size) list -> + Printf.printf "tag %d " tag; + (match size with + Some size -> Printf.printf "size %d " size + | _ -> Printf.printf "size unknown "); + Printf.printf " %d objects " (List.length !list); + List.iter (fun r -> + Printf.printf "%s " ( (*Path.name*) r.repr_path); + ) !list; + print_newline (); + ) objects; + end; + + paths, objects + +(*************************************************************************) +(* *) +(* subst *) +(* *) +(*************************************************************************) + +let rec subst args r = + match r with + Repr_unknown + | Repr_integer -> r + | Repr_variable i -> args.(i-1) + | Repr_choice list -> + Repr_choice (List.map (fun (name,r) -> name, subst args r) list) + | Repr_path (nargs, path) -> + Repr_path (List.map (subst args) nargs, path) + | Repr_block b -> + let content = match b.repr_content with + None -> None + | Some list -> Some (List.map (subst args) list) + in + Repr_block { b with repr_content = content } + +(*************************************************************************) +(* *) +(* propagate_repr *) +(* *) +(*************************************************************************) + +let rec propagate_repr types blocks continue r b = + match r with + Repr_unknown | Repr_integer | Repr_variable _ -> () + | Repr_block bb -> + + let continue = match b.block_type with + None -> + b.block_type <- Some r; + Printf.printf "Setting:"; + print_repr types "" 5 " " r; print_newline (); + 3 + | _ -> continue + in + if continue > 0 then + begin + match bb.repr_tag with + None -> () + | Some tag -> + if tag = b.block_tag then + match bb.repr_content with + None -> () + | Some list -> + let array = Array.of_list list in + for i = 0 to Array.length array - 1 do + let p = b.block_content.(i) in + if p > 1 then + let b = blocks.(p) in + propagate_repr types blocks (continue-1) array.(i) b + done + else assert false + end + + | Repr_path (args, path) -> + let continue = match b.block_type with + None -> + b.block_type <- Some r; + Printf.printf "Setting:"; + print_repr types "" 5 " " r; print_newline (); + 3 + | Some rr when r = rr -> continue + + | Some (Repr_path ([],path')) when + path = path' && List.length args > 0 -> + Printf.printf "Better args"; print_newline (); + b.block_type <- Some r; + 5 + + | Some rr -> + Printf.printf "different"; print_newline (); + print_repr types "" 5 " " r; print_newline (); + print_repr types "" 5 " " rr; print_newline (); + print_newline (); + 0 + in + if continue > 0 then + begin try + let r = Hashtbl.find types path in + let args = Array.of_list args in + let r = subst args r.repr_repr in + propagate_repr types blocks (continue-1) r b + with _ -> () + end + + | Repr_choice list -> + List.iter (fun (_, r) -> + match r with + Repr_block bb -> + begin + match bb.repr_tag with + None -> () + | Some tag -> + if tag = b.block_tag then + propagate_repr types blocks continue r b + end + | _ -> () + ) list + +(*************************************************************************) +(* *) +(* propagate_types *) +(* *) +(*************************************************************************) + +let propagate_types types hp = + let _ (* prop_blocks *) = ref 0 in + + for i = 2 to Array.length hp.hp_blocks - 1 do + let b = hp.hp_blocks.(i) in + match b.block_type with + | Some r -> + propagate_repr types hp.hp_blocks 3 r b; + | None -> () + done; + + () + +(*************************************************************************) +(* *) +(* discriminate *) +(* *) +(*************************************************************************) + +let rec discriminate paths level h p1 r = + if level = 0 then true else + if p1 = 1 && r <> Repr_integer then true else + match r with + Repr_unknown -> true + | Repr_integer -> p1 = 0 + | Repr_choice list -> + List.exists (fun (name,r) -> + discriminate paths level h p1 r + ) list + | Repr_path (args, path) -> + begin + try + let rr = Hashtbl.find paths path in + let _ (* r *) = subst (Array.of_list args) rr.repr_repr in + discriminate paths level h p1 rr.repr_repr + with _ -> + if arg_verbose_types2 () then begin + Printf.printf "Could not find description of %s" + ((*Path.name*) path); print_newline (); + end; + true + end + | Repr_variable i -> true + | Repr_block b -> + if p1 = 1 then true else + let b1 = h.hp_blocks.(p1) in + (match b.repr_tag with + Some tag -> tag = b1.block_tag + | _ -> true) && + (match b.repr_size with + Some size -> size = b1.block_size + | _ -> true) && + (match b.repr_content with + None -> true + | Some list -> + let array = Array.of_list list in + let len = Array.length array in + if len <> Array.length b1.block_content then + false + else + try + for i = 0 to len - 1 do + if not (discriminate paths (level-1) h b1.block_content.(i) + array.(i)) then raise Exit + done; + true + with _ -> false + ) + +(*************************************************************************) +(* *) +(* type_graph *) +(* *) +(*************************************************************************) + +let type_graph (types,o) hp = + + if arg_verbose_types2 () then begin + Printf.printf "Typing graph..."; print_newline (); + end; + + for p1 = 2 to Array.length hp.hp_blocks - 1 do + + let b1 = hp.hp_blocks.(p1) in + match b1.block_type with + Some _ -> () + | None -> +(* Printf.printf "For tag %d" b1.block_tag; print_newline (); *) + (*if b1.block_tag > 0 && b1.block_tag < Obj.module_tag then *) + let list1 = + try !(Hashtbl.find o (b1.block_tag,Some b1.block_size)) with _->[] + in + let list2 = + try ! (Hashtbl.find o (b1.block_tag, None)) with _ -> [] + in + let list = list1 @ list2 in + match list with + [] -> + if arg_verbose_types2 () then begin + Printf.printf "Could not find tag=%d size=%d" + b1.block_tag b1.block_size; print_newline (); + end; + | list -> + let newlist = match list with + [r] -> [r] + | _ -> + List.filter (fun r -> + discriminate types 5 hp p1 r.repr_repr) list in + match newlist with + [] -> + if arg_verbose_types () then begin + Printf.printf "After discrimination, could not find tag=%d size=%d" + b1.block_tag b1.block_size; print_newline (); + + begin + Array.iteri (fun i p -> + Printf.printf " b[%d] = %d " i p; + (if p > 1 then + let b = hp.hp_blocks.(p) in + Printf.printf " tag=%d size=%d" + b.block_tag b.block_size); + print_newline (); + ) b1.block_content + end; + + List.iter (fun r -> + print_representation types r) list; + end + + | _ :: _ :: _ -> + + if arg_verbose_types () then begin + Printf.printf "Could not discriminate block tag=%d size=%d over %d possibilities" + b1.block_tag b1.block_size (List.length list); + print_newline (); + + if b1.block_size > 6 then + begin + Array.iteri (fun i p -> + Printf.printf " b[%d] = %d " i p; + (if p > 1 then + let b = hp.hp_blocks.(p) in + Printf.printf " tag=%d size=%d" + b.block_tag b.block_size); + print_newline (); + ) b1.block_content; + + if List.length list < 5 then + List.iter (fun r -> + print_representation types r) newlist; + end; + end + + | [r] -> + let _ (* p *) = r.repr_path in + b1.block_type <- Some (Repr_path ([], r.repr_path)); + done; + + if arg_verbose_types2 () then begin + Printf.printf "Graph typed."; print_newline (); + end; + () + + +(*************************************************************************) +(* *) +(* count_types *) +(* *) +(*************************************************************************) + +let count_types hp = + + let paths = Hashtbl.create 111 in + let block_total = Array.length hp.hp_blocks in + let block_unknown = ref 0 in + let size_unknown = ref 0 in + let size_total = ref 0 in + for p1 = 2 to block_total - 1 do + + let b1 = hp.hp_blocks.(p1) in + size_total := !size_total + (b1.block_size + 1); + match b1.block_type with + Some (Repr_path (_, p)) -> + (try + let block_counter, size_counter = Hashtbl.find paths p in + incr block_counter; + size_counter := !size_counter + (b1.block_size + 1) + with Not_found -> + Hashtbl.add paths p (ref 1, ref (b1.block_size + 1))) + | _ -> + incr block_unknown; + size_unknown := !size_unknown + b1.block_size + 1 + done; + + let list = ref [!block_unknown, "unknown"] in + Hashtbl.iter (fun path (counter,_) -> + list := (!counter, (*Path.name*) path) :: !list + ) paths; + let list = List.sort (fun (s1,_) (s2,_) -> compare s2 s1) !list in + let blocks = list in + + let list = ref [!size_unknown, "unknown"] in + Hashtbl.iter (fun path (_,counter) -> + list := (!counter, (*Path.name*) path) :: !list + ) paths; + let list = List.sort (fun (s1,_) (s2,_) -> compare s2 s1) !list in + let sizes = list in + + block_total, !size_total, blocks, sizes + +let print_types (block_total, size_total, blocks, sizes) = + + print_newline (); + Printf.printf "----------------------------------"; + print_newline (); + Printf.printf "Blocks: total %d" block_total; print_newline (); + List.iter (fun (size, name) -> + Printf.printf "%d7 %s" size name; print_newline (); + ) blocks; + + print_newline (); + Printf.printf "----------------------------------"; + print_newline (); + + Printf.printf "Size: total %d" size_total; print_newline (); + List.iter (fun (size, name) -> + Printf.printf "%d7 %s" size name; print_newline (); + ) sizes; + () + +let heaps pid = + + let samples = ref [] in + + + let o = + let name = Printf.sprintf "heap.dump.%d.0" pid in + let h = HPLoadHeap.read_heap name in + parse_repr h in + + (try + for i = 0 to 100000 do + let name = Printf.sprintf "heap.dump.%d.%d" pid i in + let h = HPLoadHeap.read_heap name in + type_graph o h; + let r = count_types h in + samples := (i, r) :: !samples + done + with _ -> ()); + + +(************************************************************) + let name = Printf.sprintf "blocks_per_type.%d.hp" pid in + let oc = open_out name in + Printf.fprintf oc "JOB \"%s\"\n" "types"; + Printf.fprintf oc "DATE \"---\"\n"; + Printf.fprintf oc "SAMPLE_UNIT \"GC\"\n"; + Printf.fprintf oc "VALUE_UNIT \"values\"\n"; + + List.iter (fun (n, (block_total, size_total, blocks, sizes)) -> + Printf.fprintf oc "BEGIN_SAMPLE %d.\n" n; + + List.iter (fun (size, name) -> + Printf.fprintf oc " %s %d\n" name size) blocks; + + Printf.fprintf oc "END_SAMPLE %d.\n" n; + ) (List.rev !samples); + close_out oc; + Printf.printf "%s Generated" name; print_newline (); + +(************************************************************) + let name = Printf.sprintf "sizes_per_type.%d.hp" pid in + let oc = open_out name in + Printf.fprintf oc "JOB \"%s\"\n" "types"; + Printf.fprintf oc "DATE \"---\"\n"; + Printf.fprintf oc "SAMPLE_UNIT \"GC\"\n"; + Printf.fprintf oc "VALUE_UNIT \"values\"\n"; + + List.iter (fun (n, (block_total, size_total, blocks, sizes)) -> + Printf.fprintf oc "BEGIN_SAMPLE %d.\n" n; + + List.iter (fun (size, name) -> + Printf.fprintf oc " %s %d\n" name size) sizes; + + Printf.fprintf oc "END_SAMPLE %d.\n" n; + ) (List.rev !samples); + close_out oc; + Printf.printf "%s Generated" name; print_newline (); + +(* + +JOB "FOO -hC" +DATE "Thu Dec 26 18:17 2002" +SAMPLE_UNIT "seconds" +VALUE_UNIT "bytes" +BEGIN_SAMPLE 0.00 +END_SAMPLE 0.00 +BEGIN_SAMPLE 15.07 + ... sample data ... +END_SAMPLE 15.07 +BEGIN_SAMPLE 30.23 + ... sample data ... +END_SAMPLE 30.23 +... etc. +BEGIN_SAMPLE 11695.47 +END_SAMPLE 11695.47 + + *) diff -ruN ocaml-3.10.0.old/hp/hPGlobals.ml ocaml-3.10.0/hp/hPGlobals.ml --- ocaml-3.10.0.old/hp/hPGlobals.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hPGlobals.ml 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,19 @@ +open HPTypes + +let arg_verbose = ref 0 + +let arg_verbose_load () = !arg_verbose land 1 = 1 +let arg_verbose_types () = !arg_verbose land 2 = 2 +let arg_verbose_types2 () = !arg_verbose land 4 = 4 + +let is_block n = (n <> 0) + +let unknown_block = { + block_scanned = ref false; + block_tag = 0; + block_size = 0; + block_content = [||]; + block_reverse = []; + block_weight = 0; + block_type = None; + } diff -ruN ocaml-3.10.0.old/hp/hPLoadHeap.ml ocaml-3.10.0/hp/hPLoadHeap.ml --- ocaml-3.10.0.old/hp/hPLoadHeap.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hPLoadHeap.ml 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,225 @@ +open HPTypes +open HPGlobals + +type loader = { + new_block : (int -> int -> int -> int array -> unit); + load_pointer : (in_channel -> int); + } + +(*************************************************************************) +(* *) +(* load_int *) +(* *) +(*************************************************************************) + +let load_int ic = + let c0 = int_of_char (input_char ic) in + let c1 = int_of_char (input_char ic) in + let c2 = int_of_char (input_char ic) in + let c3 = int_of_char (input_char ic) in + c0 lor + (c1 lsl 8) lor + (c2 lsl 16) lor + (c3 lsl 24) + +(*************************************************************************) +(* *) +(* load_file *) +(* *) +(*************************************************************************) + +let load_file filename l = + + let ic = open_in_bin filename in + + let size = int_of_char (input_char ic) in + if arg_verbose_load () then begin + Printf.printf "sizeof(value): %d\n" size; print_newline (); + end; + + let namesize = load_int ic in + let binary_name = String.create namesize in + really_input ic binary_name 0 namesize; + if arg_verbose_load () then begin + Printf.printf "Binary: %s (%d)" binary_name namesize; print_newline (); + end; + + let rec iter_chunk chunks = + let opcode = int_of_char (input_char ic) in + if opcode = 0 then begin + for i = 1 to 2 * size do ignore (input_char ic); done; +(* Printf.printf "chunk"; print_newline (); *) + iter_chunk chunks + end else + if opcode = 1 then begin +(* Printf.printf "load value"; print_newline (); *) + let pointer = l.load_pointer ic in + let tag = int_of_char (input_char ic) in + let size = load_int ic in +(* Printf.printf "block size %d tag %d \n" size tag; print_newline (); *) + if tag < 251 then + let b = Array.create size 0 in + for i = 0 to size - 1 do +(* Printf.printf "load field %d" i; print_newline (); *) + b.(i) <- l.load_pointer ic; + done; + l.new_block pointer tag size b + else + l.new_block pointer tag size [||]; + iter_chunk chunks + end else + if opcode = 10 then + iter_chunk chunks + else + begin + chunks + end + in + let _ (* chunks *) = iter_chunk [] in + + let _ (* code_area_start *) = l.load_pointer ic in + let _ (* code_area_end *) = l.load_pointer ic in + + let _ (* delim *) = load_int ic in +(* Printf.printf "Delim %d\n" delim; *) + + let len = load_int ic in + let globals_map = String.create len in + really_input ic globals_map 0 len; + let (globals_map : (string * string) list) = + Marshal.from_string globals_map 0 in + let globals_map = List.map fst globals_map in + let globals_map = Array.of_list globals_map in + + let rec iter list = + let v = load_int ic in + if v = 0 then List.rev list else + let tag = Obj.module_tag in + let pointer = l.load_pointer ic in + let size = load_int ic in + let b = Array.create size 0 in + for i = 0 to size - 1 do + b.(i) <- l.load_pointer ic; + done; + l.new_block pointer tag size b; + iter (pointer :: list) + in + let caml_globals = iter [] in + let caml_globals = Array.of_list caml_globals in + + let rec iter list = + let v = load_int ic in + if v = 0 then List.rev list else + let len = load_int ic in + let info = String.create len in + really_input ic info 0 len; + iter (info :: list) + in + let infos = iter [] in + let infos = List.map (fun s -> + + (Marshal.from_string s 0 : Typeopt.mem_repr) + ) infos in + let infos = Array.of_list infos in + + close_in ic; + { + binary_name = binary_name; + caml_globals = caml_globals; + mem_repr = infos; + globals_map = globals_map; + } + +(*************************************************************************) +(* *) +(* load_pointer *) +(* *) +(*************************************************************************) + +let load_pointer ic = + let c0 = int_of_char (input_char ic) in + let c1 = int_of_char (input_char ic) in + let c2 = int_of_char (input_char ic) in + let c3 = int_of_char (input_char ic) in + if c0 land 1 = 1 then 0 else + (c0 lsr 1) lor + (c1 lsl 7) lor + (c2 lsl 15) lor + (c3 lsl 23) + +(*************************************************************************) +(* *) +(* read_heap *) +(* *) +(*************************************************************************) + +let read_heap filename = + let blocks = Hashtbl.create 1111 in + let counter = ref 2 in (* 0 is INTEGER, 1 is UNKNOWN *) + + let new_block pointer tag size b = + Hashtbl.add blocks pointer !counter; + incr counter + in + + let loader = { + new_block = new_block; + load_pointer = load_pointer; + } in + + let _ (* h *) = load_file filename loader in + + Printf.printf "Heap contains %d blocks" !counter; print_newline (); + let array = Array.create !counter unknown_block in + + let new_block pointer tag size b = + array.(pointer) <- { + block_scanned = ref false; + block_tag = tag; + block_size = size; + block_content = b; + block_reverse = []; + block_weight = 0; + block_type = None; + } + in + let load_pointer ic = + let p = load_pointer ic in + if p = 0 then 0 else + try + Hashtbl.find blocks p + with _ -> 1 + in + + let loader = { + new_block = new_block; + load_pointer = load_pointer; + } in + + let h = load_file filename loader in + + let h = { + hp_blocks = array; + hp_info = h; + } in + h + + +(* + +let read_repr filename = + + let new_block pointer tag size b = () in + let loader = { + new_block = new_block; + load_pointer = load_pointer; + } in + + let h = load_file filename loader in + + let h = { + hp_blocks = [||]; + hp_info = h; + } in + h +*) diff -ruN ocaml-3.10.0.old/hp/hPMain.ml ocaml-3.10.0/hp/hPMain.ml --- ocaml-3.10.0.old/hp/hPMain.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hPMain.ml 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,45 @@ +open HPGlobals + + +let arg_close_graph = ref false +let arg_memory_per_module = ref false +let arg_memory_per_root = ref false +let arg_memory_per_type = ref false + +let _ = + Arg.parse [ + + "-modules", Arg.Set arg_memory_per_module, " : compute memory retained per module"; + + "-roots", Arg.Set arg_memory_per_root, " : compute memory retained per root"; + "-types", Arg.Set arg_memory_per_type, " : compute repartition by types"; + + "-v", Arg.Int ((:=) arg_verbose), " : set verbosity (0=no, 1=loading, 2=more,...)"; + "-heap", Arg.String (fun s -> + + let h = HPLoadHeap.read_heap s in + + if !arg_close_graph then HPCompute.close_graph h; + if !arg_memory_per_module then + ignore (HPCompute.compute_memory_per_module h); + if !arg_memory_per_root then + ignore (HPCompute.compute_memory_per_root h); + + if !arg_memory_per_type then begin + let o = HPCompute.parse_repr h in + HPCompute.type_graph o h; + let r = HPCompute.count_types h in + HPCompute.print_types r; + end; + () + )," : load the type description from "; + + "-heaps", Arg.Int (fun pid -> + HPCompute.heaps pid), " : ......"; + ] + (fun s -> + Printf.printf "Error: don't know what to do with %s" s; + print_newline (); + exit 1) + "Ocaml Heap Profiler" + \ No newline at end of file diff -ruN ocaml-3.10.0.old/hp/hPMisc.ml ocaml-3.10.0/hp/hPMisc.ml --- ocaml-3.10.0.old/hp/hPMisc.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hPMisc.ml 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,7 @@ + + +let start_scan h = + () + +let stop_scan h = + () \ No newline at end of file diff -ruN ocaml-3.10.0.old/hp/hPScanHeap.ml ocaml-3.10.0/hp/hPScanHeap.ml --- ocaml-3.10.0.old/hp/hPScanHeap.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hPScanHeap.ml 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,29 @@ +open HPTypes +open HPGlobals + +let rec iter h p n = + let b = h.hp_blocks.(p) in + if not ! (b.block_scanned) then begin + if b.block_tag >= Obj.no_scan_tag then begin + b.block_scanned := true; + n := !n + b.block_size; + end else begin + +(* Printf.printf "Scanning block %ld size %d\n" p b.block_size; *) + b.block_scanned := true; + n := !n + b.block_size; + for i = 0 to Array.length b.block_content - 1 do + iter h b.block_content.(i) n + done + end + end + +let scan h p = + Array.iter (fun b -> + if ! (b.block_scanned) then b.block_scanned := false + ) h.hp_blocks; + let n = ref 0 in + iter h p n; +(* Printf.printf "SCANNED: %d <-> WEIGHT: %d" + !n h.hp_blocks.(p).block_weight; print_newline (); *) + !n diff -ruN ocaml-3.10.0.old/hp/hPTypes.ml ocaml-3.10.0/hp/hPTypes.ml --- ocaml-3.10.0.old/hp/hPTypes.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/hp/hPTypes.ml 2007-11-13 00:15:24.000000000 +0000 @@ -0,0 +1,45 @@ +open Datarepr + + (* +type block_name = + Block_anonymous of string * int +| Block_alloc of Location.t +| Block_typedef of Ident.t +| Block_name of Ident.t +| Block_path of path + *) + +type block = { + mutable block_scanned : bool ref; + block_tag : int; + block_size : int; + block_content : int array; + mutable block_reverse : int list; + mutable block_weight : int; + mutable block_type : Typeopt.type_repr option; + } + +type heap_info = { + binary_name : string; + caml_globals : int array; + mem_repr : Typeopt.mem_repr array; + globals_map : string array; + } + +type heap = { + hp_blocks : block array; + hp_info : heap_info; + (* + mutable prog_name : string; + mutable npointers : int; + mutable nobjects : int; + mutable global_data : int; + mutable codepointer : int; + mutable restart_codepointer : int; + mutable stack : int array; +mutable roots : int list; + *) + } + + + \ No newline at end of file diff -ruN ocaml-3.10.0.old/Makefile ocaml-3.10.0/Makefile --- ocaml-3.10.0.old/Makefile 2007-11-13 00:14:58.000000000 +0000 +++ ocaml-3.10.0/Makefile 2007-11-13 00:19:08.000000000 +0000 @@ -32,7 +32,7 @@ MKDIR=mkdir -p INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \ - -I toplevel + -I toplevel -I hp UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \ @@ -124,7 +124,7 @@ # Recompile the system using the bootstrap compiler all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \ - otherlibraries ocamlbuild.byte camlp4out $(DEBUGGER) ocamldoc + otherlibraries ocamlbuild.byte camlp4out $(DEBUGGER) # The compilation of ocaml will fail if the runtime has changed. # Never mind, just do make bootstrap to reach fixpoint again. @@ -224,13 +224,13 @@ rm -rf boot/Saved/Saved.prev/* # Compile the native-code compiler -opt-core:runtimeopt ocamlopt libraryopt +opt-core:runtimeopt ocamlopt hp libraryopt opt: runtimeopt ocamlopt libraryopt otherlibrariesopt # Native-code versions of the tools opt.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \ ocamlbuild.byte camlp4out $(DEBUGGER) ocamldoc ocamlopt.opt otherlibrariesopt \ - ocamllex.opt ocamltoolsopt.opt ocamlbuild.native camlp4opt ocamldoc.opt + ocamllex.opt hp.opt ocamltoolsopt.opt ocamlbuild.native camlp4opt ocamldoc.opt # Installation install: FORCE @@ -257,7 +257,6 @@ for i in $(OTHERLIBRARIES); do \ (cd otherlibs/$$i; $(MAKE) install) || exit $$?; \ done - cd ocamldoc; $(MAKE) install if test -f ocamlopt; then $(MAKE) installopt; else :; fi if test -f debugger/ocamldebug; then (cd debugger; $(MAKE) install); \ else :; fi @@ -268,11 +267,14 @@ installopt: cd asmrun; $(MAKE) install cp ocamlopt $(BINDIR)/ocamlopt$(EXE) + cp heapstats $(BINDIR)/heapstats$(EXE) + cp hp2ps $(BINDIR)/hp2ps cd stdlib; $(MAKE) installopt - cd ocamldoc; $(MAKE) installopt for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) installopt) || exit $$?; done if test -f ocamlc.opt; \ then cp ocamlc.opt $(BINDIR)/ocamlc.opt$(EXE); else :; fi + if test -f heapstats.opt; \ + then cp heapstats.opt $(BINDIR)/heapstats.opt$(EXE); else :; fi if test -f ocamlopt.opt; \ then cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE); else :; fi if test -f lex/ocamllex.opt; \ @@ -492,6 +494,32 @@ cd tools; \ $(MAKE) CAMLC="../$(CAMLRUN) ../boot/ocamlc -I ../stdlib" cvt_emit +hp: hp2ps heapstats + +hp.opt: hp2ps heapstats.opt + + +# The "hp2ps" utility + +hp2ps: + cd hp/hp2ps; $(MAKE) + +partialclean:: + cd hp/hp2ps; $(MAKE) clean + +# The "heapstats" utility + +HEAPSTATS= $(UTILS) $(PARSING) $(TYPING) $(COMP) \ + hp/hPTypes.cmo hp/hPGlobals.cmo hp/hPScanHeap.cmo hp/hPLoadHeap.cmo hp/hPCompute.cmo hp/hPMain.cmo + +heapstats: $(HEAPSTATS) + $(CAMLC) -custom $(COMPFLAGS) -o heapstats $(HEAPSTATS) +heapstats.opt: $(HEAPSTATS:.cmo=.cmx) + $(CAMLOPT) $(LINKFLAGS) -o heapstats.opt $(HEAPSTATS:.cmo=.cmx) + +partialclean:: + rm -f heapstats heapstats.opt + # The "expunge" utility expunge: $(EXPUNGEOBJS) @@ -671,10 +699,11 @@ rm -f driver/*.cm[iox] driver/*.[so] driver/*~ rm -f toplevel/*.cm[iox] toplevel/*.[so] toplevel/*~ rm -f tools/*.cm[iox] tools/*.[so] tools/*~ + rm -f hp/*.cm[iox] hp/*.[so] hp/*~ rm -f *~ depend: beforedepend - (for d in utils parsing typing bytecomp asmcomp driver toplevel; \ + (for d in utils parsing typing bytecomp asmcomp driver toplevel hp; \ do $(CAMLDEP) $(DEPFLAGS) $$d/*.mli $$d/*.ml; \ done) > .depend diff -ruN ocaml-3.10.0.old/ocamldoc/odoc_ast.ml ocaml-3.10.0/ocamldoc/odoc_ast.ml --- ocaml-3.10.0.old/ocamldoc/odoc_ast.ml 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/ocamldoc/odoc_ast.ml 2007-11-13 00:15:24.000000000 +0000 @@ -318,7 +318,6 @@ in (new_param, func_body2) | _ -> - print_DEBUG3 "Pas le bon filtre pour le paramètre optionnel avec valeur par défaut."; (parameter, func_body) ) ) @@ -463,7 +462,6 @@ in (new_param, body2) | _ -> - print_DEBUG3 "Pas le bon filtre pour le paramètre optionnel avec valeur par défaut."; (parameter, body) ) ) diff -ruN ocaml-3.10.0.old/ocamldoc/odoc.ml ocaml-3.10.0/ocamldoc/odoc.ml --- ocaml-3.10.0.old/ocamldoc/odoc.ml 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/ocamldoc/odoc.ml 2007-11-13 00:15:24.000000000 +0000 @@ -85,7 +85,6 @@ prerr_endline (Odoc_messages.load_file_error file s); exit 1 -let _ = print_DEBUG "Fin du chargement dynamique éventuel" let default_html_generator = new Odoc_html.html let default_latex_generator = new Odoc_latex.latex diff -ruN ocaml-3.10.0.old/README.memprof ocaml-3.10.0/README.memprof --- ocaml-3.10.0.old/README.memprof 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-3.10.0/README.memprof 2007-11-12 23:03:35.000000000 +0000 @@ -0,0 +1,126 @@ +Ocaml 3.09.3 with memory profiling support version 1.3 +------------------------------------------ + +This patch was originally designed by Fabrice Le Fessant. + +ChangeLog: + + * version 1.4: + - Updated for OCaml 3.10.0 by Samuel Mimram. + * version 1.3: + - Updated for OCaml 3.09.3 by Samuel Mimram. + * version 1.2: + - Updated for OCaml 3.08.3 by spiralvoice. + * version 1.1: + - Draw simple graphs using hp2ps (see HOW TO USE version 1.1). + * version 1.0: + - See HOW TO USE version 1.0. + +INTRODUCTION: +------------- + + This is a beta version, just a few days of work, so be indulgent! + + Use an image of the memory of the application saved on disk to display + informations about how the memory is used by the application. + + Note that you need more memory on your computer than the memory used by + the application (i.e. my application uses 70 MB of memory, I needed at + least 250 MB to load the image in memory for analysis). + + The information given is pretty simple. The memory retained by every + identified root (memory can be retained by several roots at a time), + and space used by every identified type. + + The main interest of the approach is that profiling your program + memory is done without any cost on the program execution speed or + memory usage. + + The algorithms used are very simple, far from optimal. Lot of work is + needed (1) to implement optimal graph algorithms (2) to display the + _interesting_ information so that it can be used to improve the + program (3) to modify the compiler to get more information (4) to + interface with gnuplot to have nice drawings. + +HOW TO USE version 1.0 +---------------------- + +* Patch a clean image of ocaml: + + In ocaml-3.07: + patch -p1 < ocaml-3.07-memprof.patch + +* Compile ocaml and install. Don't forget the target "opt.opt": + + ./configure + make world + + An error should appear while compiling "expunge". No problem, it's normal. + This error looks like this: + +Error while linking boot/stdlib.cma(Gc): +The external function `caml_dump_heap' is not available + + make bootstrap + make bootstrap + make world + make opt opt.opt + make install installopt + + The analyser is compiled and install with ocaml, its sources are in + the hp/ subdirectory. + +* Compile the software you want to profile in NATIVE CODE (ie with ocamlopt + or ocamlopt.opt). Somewhere in the code, you should use + + Gc.dump_heap () + + to dump an image of the memory on the disk. You can do that using a + signal: when receiving a HUP signal, the application will dump its + memory on disk for future profiling. + + Sys.set_signal Sys.sighup (Sys.Signal_handle (fun _ -> Gc.dump_heap ())); + +* A memory image on disk looks like: + + heap.dump..' where is the number of + your program pid, and heapstats.opt will output two files, + 'blocks_per_type..hp' and 'sizes_per_type..hp'. + + Now, you run hp2ps on every .hp file, to obtain the corresponding .ps + file, that you can view using gv -seascape blocks_per_type..ps + for example. diff -ruN ocaml-3.10.0.old/stdlib/gc.ml ocaml-3.10.0/stdlib/gc.ml --- ocaml-3.10.0.old/stdlib/gc.ml 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/stdlib/gc.ml 2007-11-13 00:15:24.000000000 +0000 @@ -98,3 +98,5 @@ ;; let delete_alarm a = a := false;; + +external dump_heap : unit -> unit = "caml_dump_heap" \ No newline at end of file diff -ruN ocaml-3.10.0.old/stdlib/gc.mli ocaml-3.10.0/stdlib/gc.mli --- ocaml-3.10.0.old/stdlib/gc.mli 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/stdlib/gc.mli 2007-11-13 00:15:24.000000000 +0000 @@ -258,3 +258,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 -ruN ocaml-3.10.0.old/stdlib/obj.ml ocaml-3.10.0/stdlib/obj.ml --- ocaml-3.10.0.old/stdlib/obj.ml 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/stdlib/obj.ml 2007-11-13 00:15:24.000000000 +0000 @@ -36,6 +36,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 -ruN ocaml-3.10.0.old/stdlib/obj.mli ocaml-3.10.0/stdlib/obj.mli --- ocaml-3.10.0.old/stdlib/obj.mli 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/stdlib/obj.mli 2007-11-13 00:15:24.000000000 +0000 @@ -34,6 +34,16 @@ external new_block : int -> int -> t = "caml_obj_block" external dup : t -> t = "caml_obj_dup" +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 -ruN ocaml-3.10.0.old/typing/datarepr.ml ocaml-3.10.0/typing/datarepr.ml --- ocaml-3.10.0.old/typing/datarepr.ml 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/typing/datarepr.ml 2007-11-13 00:15:24.000000000 +0000 @@ -19,6 +19,12 @@ open Asttypes open Types +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 in List.iter @@ -39,6 +45,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_private = priv } in @@ -50,6 +58,7 @@ cstr_args = decl; cstr_arity = List.length decl; cstr_tag = Cstr_exception path_exc; + cstr_alloc_tag = 0; cstr_consts = -1; cstr_nonconsts = -1; cstr_private = Public } @@ -59,10 +68,23 @@ let dummy_label = { 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 -> @@ -72,6 +94,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 -ruN ocaml-3.10.0.old/typing/datarepr.mli ocaml-3.10.0/typing/datarepr.mli --- ocaml-3.10.0.old/typing/datarepr.mli 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/typing/datarepr.mli 2007-11-13 00:15:24.000000000 +0000 @@ -24,7 +24,7 @@ val exception_descr: Path.t -> type_expr list -> constructor_description val label_descrs: - type_expr -> (string * mutable_flag * type_expr) list -> + Path.t -> type_expr -> (string * mutable_flag * type_expr) list -> record_representation -> private_flag -> (string * label_description) list @@ -32,3 +32,7 @@ val find_constr_by_tag: constructor_tag -> (string * type_expr list) list -> string * type_expr list + +val record_tag : string list -> int +val constructor_tag : (string * 'a) list -> int + \ No newline at end of file diff -ruN ocaml-3.10.0.old/typing/env.ml ocaml-3.10.0/typing/env.ml --- ocaml-3.10.0.old/typing/env.ml 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/typing/env.ml 2007-11-13 00:15:24.000000000 +0000 @@ -52,6 +52,7 @@ components: (Path.t * module_components) Ident.tbl; classes: (Path.t * class_declaration) Ident.tbl; cltypes: (Path.t * cltype_declaration) Ident.tbl; + path : string list; summary: summary } @@ -87,7 +88,7 @@ labels = Ident.empty; types = Ident.empty; modules = Ident.empty; modtypes = Ident.empty; components = Ident.empty; classes = Ident.empty; - cltypes = Ident.empty; + cltypes = Ident.empty; path = []; summary = Env_empty } let diff_keys tbl1 tbl2 = @@ -428,7 +429,7 @@ let labels_of_type ty_path decl = match decl.type_kind with Type_record(labels, rep, priv) -> - Datarepr.label_descrs + Datarepr.label_descrs ty_path (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) labels rep priv | Type_variant _ | Type_abstract -> [] @@ -787,6 +788,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 -ruN ocaml-3.10.0.old/typing/env.mli ocaml-3.10.0/typing/env.mli --- ocaml-3.10.0.old/typing/env.mli 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/typing/env.mli 2007-11-13 00:15:24.000000000 +0000 @@ -140,3 +140,5 @@ val check_modtype_inclusion: (t -> module_type -> Path.t -> module_type -> unit) ref +val enter_sub_module : t -> string -> t +val sub_module : t -> string list \ No newline at end of file diff -ruN ocaml-3.10.0.old/typing/path.ml ocaml-3.10.0/typing/path.ml --- ocaml-3.10.0.old/typing/path.ml 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/typing/path.ml 2007-11-13 00:15:24.000000000 +0000 @@ -39,7 +39,7 @@ let rec name = function Pident id -> Ident.name id - | Pdot(p, s, pos) -> name p ^ "." ^ s + | Pdot(p, s, pos) -> Printf.sprintf "%s.%s" (name p) s | Papply(p1, p2) -> name p1 ^ "(" ^ name p2 ^ ")" let rec head = function diff -ruN ocaml-3.10.0.old/typing/typemod.ml ocaml-3.10.0/typing/typemod.ml --- ocaml-3.10.0.old/typing/typemod.ml 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/typing/typemod.ml 2007-11-13 00:15:24.000000000 +0000 @@ -615,7 +615,8 @@ final_env) | {pstr_desc = Pstr_module(name, smodl); pstr_loc = loc} :: srem -> check "module" loc module_names name; - let modl = type_module (anchor_submodule name anchor) env smodl in + let modl = type_module (anchor_submodule name anchor) + (Env.enter_sub_module env name) smodl in let mty = enrich_module_type anchor name modl.mod_type env in let (id, newenv) = Env.enter_module name mty env in let (str_rem, sig_rem, final_env) = type_struct newenv srem in diff -ruN ocaml-3.10.0.old/typing/types.ml ocaml-3.10.0/typing/types.ml --- ocaml-3.10.0.old/typing/types.ml 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/typing/types.ml 2007-11-13 00:15:24.000000000 +0000 @@ -105,6 +105,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_private: private_flag } (* Read-only constructor? *) @@ -121,6 +122,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 -ruN ocaml-3.10.0.old/typing/types.mli ocaml-3.10.0/typing/types.mli --- ocaml-3.10.0.old/typing/types.mli 2007-11-13 00:14:59.000000000 +0000 +++ ocaml-3.10.0/typing/types.mli 2007-11-13 00:15:24.000000000 +0000 @@ -106,6 +106,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_private: private_flag } (* Read-only constructor? *) @@ -122,6 +123,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? *)