Permalink
Browse files

[feature] BaseObj: size

  • Loading branch information...
1 parent e88f8a6 commit 9c57f20288421c65398930323d921ecea48c0250 @OpaOnWindowsNow OpaOnWindowsNow committed Jun 18, 2012
Showing with 73 additions and 0 deletions.
  1. +71 −0 ocamllib/libbase/baseObj.ml
  2. +2 −0 ocamllib/libbase/baseObj.mli
View
71 ocamllib/libbase/baseObj.ml
@@ -123,3 +123,74 @@ let print ?prefix x =
match prefix with
| None -> print_endline (dump x)
| Some s -> Printf.printf "%s: %s\n%!" s (dump x)
+
+(* To detect cycles in full_size *)
+module Set = struct
+ exception ERROR
+ let create() = Hashtbl.create 101
+ let getadd a = ((Obj.magic a) lxor 0)
+ let add set a =
+ let b = getadd a in
+ if Hashtbl.mem set b then raise ERROR
+ else Hashtbl.add set b ()
+ let rm set a = Hashtbl.remove set (getadd a)
+end
+
+
+
+let size a =
+ let word_size = 8 in
+ let header_size = 1 in
+ let int_size = 1 in
+ let field_size = 1 in
+ let unknown_size = 1 in
+ let double_size = if word_size = 8 then 1 else 2 in
+ let set = Set.create() in
+ let rec aux depth t =
+ try
+ Set.add set t;
+ if depth < 10000 then failwith "Obj.full_size: Too deep";
+ let r = aux_ (depth+1) t in
+ Set.rm set t;
+ r
+ with Set.ERROR -> 0 (* Cycle detected *)
+ and aux_fields depth t =
+ let nb_field = Obj.size t in
+ let r = ref 0 in
+ for i = 0 to nb_field - 1 do
+ r:= !r + aux depth (Obj.field t i)
+ done;
+ !r + header_size + field_size * nb_field
+ and aux_ depth t =
+ let v = Obj.obj t in
+ let tag = Obj.tag t in
+ if tag = Obj.int_tag then int_size
+ else if tag = 0 then
+ aux_fields depth t
+ else if tag = Obj.string_tag then
+ let len = String.length v in
+ let pad = if len mod word_size = 0 then 0 else 1 in
+ header_size + len + pad
+ else if tag = Obj.double_tag then
+ double_size
+ else if tag = Obj.double_array_tag then
+ header_size + double_size * (Array.length v)
+ else if tag = Obj.out_of_heap_tag then
+ 0
+ else if tag = Obj.lazy_tag ||
+ tag = Obj.closure_tag ||
+ tag = Obj.object_tag ||
+ tag = Obj.infix_tag ||
+ tag = Obj.forward_tag ||
+ tag = Obj.no_scan_tag ||
+ tag = Obj.abstract_tag ||
+ tag = Obj.custom_tag ||
+ tag = Obj.final_tag ||
+ tag = Obj.unaligned_tag ||
+ tag >= Obj.no_scan_tag
+ then
+ unknown_size
+ else (* => tag < Obj.no_scan_tag *)
+ aux_fields depth t
+ in
+ (aux 0 (Obj.repr a)) * word_size
View
2 ocamllib/libbase/baseObj.mli
@@ -64,6 +64,8 @@ val dump : ?custom:(Obj.t -> (Buffer.t -> Obj.t -> unit) option) -> ?depth:int -
val print : ?prefix:string -> 'a -> unit
(** print the value to stdout, possibly prefixed by the given string *)
+val size : 'a -> int
+
val native_runtime : bool
(** [native_runtime = true] when the code currently
executing is native code *)

0 comments on commit 9c57f20

Please sign in to comment.