stdlib/obj.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the GNU Library General Public License, with    *)
  10 (*  the special exception on linking described in file ../LICENSE.     *)
  11 (*                                                                     *)
  12 (* portions lifted from Extlib                                         *)
  13 (* Copyright (C) 2003 Brian Hurt                                       *)
  14 (* Copyright (C) 2003 Nicolas Cannasse                                 *)
  15 (***********************************************************************)
  16
  17 (* $Id$ *)
  18
  19 (* Operations on internal representations of values *)
  20
  21 type t
  22
  23 external repr : 'a -> t = "%identity"
  24 external obj : t -> 'a = "%identity"
  25 external magic : 'a -> 'b = "%identity"
  26 external is_block : t -> bool = "caml_obj_is_block"
  27 external is_int : t -> bool = "%obj_is_int"
  28 external tag : t -> int = "caml_obj_tag"
  29 external set_tag : t -> int -> unit = "caml_obj_set_tag"
  30 external size : t -> int = "%obj_size"
  31 external field : t -> int -> t = "%obj_field"
  32 external set_field : t -> int -> t -> unit = "%obj_set_field"
  33 external new_block : int -> int -> t = "caml_obj_block"
  34 external dup : t -> t = "caml_obj_dup"
  35 external truncate : t -> int -> unit = "caml_obj_truncate"
  36
  37 let marshal (obj : t) =
  38   Marshal.to_string obj []
  39 let unmarshal str pos =
  40   (Marshal.from_string str pos, pos + Marshal.total_size str pos)
  41
  42 let lazy_tag = 246
  43 let closure_tag = 247
  44 let object_tag = 248
  45 let infix_tag = 249
  46 let forward_tag = 250
  47
  48 let no_scan_tag = 251
  49
  50 let abstract_tag = 251
  51 let string_tag = 252
  52 let double_tag = 253
  53 let double_array_tag = 254
  54 let custom_tag = 255
  55 let final_tag = custom_tag
  56
  57
  58 let int_tag = 1000
  59 let out_of_heap_tag = 1001
  60
  61 let rec dump r =
  62   if is_int r then
  63     string_of_int (magic r : int)
  64   else (* Block. *)
  65     let rec get_fields acc = function
  66       | 0 -> acc
  67       | n -> let n = n-1 in get_fields (field r n :: acc) n
  68     in
  69     let rec is_list r =
  70       if is_int r then
  71         r = repr 0 (* [] *)
  72       else
  73         let s = size r and t = tag r in
  74         t = 0 && s = 2 && is_list (field r 1) (* h :: t *)
  75         in
  76     let rec get_list r =
  77       if is_int r then
  78         []
  79       else
  80         let h = field r 0 and t = get_list (field r 1) in
  81         h :: t
  82     in
  83     let opaque name =
  84       (* XXX In future, print the address of value 'r'.  Not possible in
  85        * pure OCaml at the moment.
  86        *)
  87       "<" ^ name ^ ">"
  88     in
  89     let s = size r and t = tag r in
  90     (* From the tag, determine the type of block. *)
  91     match t with
  92       | _ when is_list r ->
  93           let fields = get_list r in
  94           "[" ^ String.concat "; " (List.map dump fields) ^ "]"
  95       | 0 ->
  96           let fields = get_fields [] s in
  97           "(" ^ String.concat ", " (List.map dump fields) ^ ")"
  98       | x when x = lazy_tag ->
  99           (* Note that [lazy_tag .. forward_tag] are < no_scan_tag.  Not
 100            * clear if very large constructed values could have the same
 101            * tag. XXX *)
 102           opaque "lazy"
 103       | x when x = closure_tag ->
 104           opaque "closure"
 105       | x when x = object_tag ->
 106           let fields = get_fields [] s in
 107           let clasz, id, slots =
 108             match fields with
 109               | h::h'::t -> h, h', t
 110               | _ -> assert false
 111           in
 112           (* No information on decoding the class (first field).  So just print
 113            * out the ID and the slots. *)
 114           "Object #" ^ dump id ^ " (" ^ String.concat ", " (List.map dump slots) ^ ")"
 115       | x when x = infix_tag ->
 116           opaque "infix"
 117       | x when x = forward_tag ->
 118           opaque "forward"
 119       | x when x < no_scan_tag ->
 120           let fields = get_fields [] s in
 121           "Tag" ^ string_of_int t ^
 122             " (" ^ String.concat ", " (List.map dump fields) ^ ")"
 123       | x when x = string_tag ->
 124           "\"" ^ String.escaped (magic r : string) ^ "\""
 125       | x when x = double_tag ->
 126           string_of_float (magic r : float)
 127       | x when x = abstract_tag ->
 128           opaque "abstract"
 129       | x when x = custom_tag ->
 130           opaque "custom"
 131       | x when x = final_tag ->
 132           opaque "final"
 133       | _ ->
 134           failwith ("Std.dump: impossible tag (" ^ string_of_int t ^ ")")
 135
 136 let dump v = dump (repr v)
 137
 138 let print v = print_endline (dump v)
 139
 140 let __unique_counter = ref 0
 141
 142 let unique_int () =
 143   incr __unique_counter;
 144   !__unique_counter