l4/pkg/ocaml/ocaml/contrib/stdlib/camlinternalOO.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 2002 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 (***********************************************************************)
  13
  14 (* $Id: camlinternalOO.ml 8768 2008-01-11 16:13:18Z doligez $ *)
  15
  16 open Obj
  17
  18 (**** Object representation ****)
  19
  20 let last_id = ref 0
  21 let new_id () =
  22   let id = !last_id in incr last_id; id
  23
  24 let set_id o id =
  25   let id0 = !id in
  26   Array.unsafe_set (Obj.magic o : int array) 1 id0;
  27   id := id0 + 1
  28
  29 (**** Object copy ****)
  30
  31 let copy o =
  32   let o = (Obj.obj (Obj.dup (Obj.repr o))) in
  33   set_id o last_id;
  34   o
  35
  36 (**** Compression options ****)
  37 (* Parameters *)
  38 type params = {
  39     mutable compact_table : bool;
  40     mutable copy_parent : bool;
  41     mutable clean_when_copying : bool;
  42     mutable retry_count : int;
  43     mutable bucket_small_size : int
  44   }
  45
  46 let params = {
  47   compact_table = true;
  48   copy_parent = true;
  49   clean_when_copying = true;
  50   retry_count = 3;
  51   bucket_small_size = 16
  52 }
  53
  54 (**** Parameters ****)
  55
  56 let step = Sys.word_size / 16
  57 let initial_object_size = 2
  58
  59 (**** Items ****)
  60
  61 type item = DummyA | DummyB | DummyC of int
  62
  63 let dummy_item = (magic () : item)
  64
  65 (**** Types ****)
  66
  67 type tag
  68 type label = int
  69 type closure = item
  70 type t = DummyA | DummyB | DummyC of int
  71 type obj = t array
  72 external ret : (obj -> 'a) -> closure = "%identity"
  73
  74 (**** Labels ****)
  75
  76 let public_method_label s : tag =
  77   let accu = ref 0 in
  78   for i = 0 to String.length s - 1 do
  79     accu := 223 * !accu + Char.code s.[i]
  80   done;
  81   (* reduce to 31 bits *)
  82   accu := !accu land (1 lsl 31 - 1);
  83   (* make it signed for 64 bits architectures *)
  84   let tag = if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu in
  85   (* Printf.eprintf "%s = %d\n" s tag; flush stderr; *)
  86   magic tag
  87
  88 (**** Sparse array ****)
  89
  90 module Vars = Map.Make(struct type t = string let compare = compare end)
  91 type vars = int Vars.t
  92
  93 module Meths = Map.Make(struct type t = string let compare = compare end)
  94 type meths = label Meths.t
  95 module Labs = Map.Make(struct type t = label let compare = compare end)
  96 type labs = bool Labs.t
  97
  98 (* The compiler assumes that the first field of this structure is [size]. *)
  99 type table =
 100  { mutable size: int;
 101    mutable methods: closure array;
 102    mutable methods_by_name: meths;
 103    mutable methods_by_label: labs;
 104    mutable previous_states:
 105      (meths * labs * (label * item) list * vars *
 106       label list * string list) list;
 107    mutable hidden_meths: (label * item) list;
 108    mutable vars: vars;
 109    mutable initializers: (obj -> unit) list }
 110
 111 let dummy_table =
 112   { methods = [| dummy_item |];
 113     methods_by_name = Meths.empty;
 114     methods_by_label = Labs.empty;
 115     previous_states = [];
 116     hidden_meths = [];
 117     vars = Vars.empty;
 118     initializers = [];
 119     size = 0 }
 120
 121 let table_count = ref 0
 122
 123 (* dummy_met should be a pointer, so use an atom *)
 124 let dummy_met : item = obj (Obj.new_block 0 0)
 125 (* if debugging is needed, this could be a good idea: *)
 126 (* let dummy_met () = failwith "Undefined method" *)
 127
 128 let rec fit_size n =
 129   if n <= 2 then n else
 130   fit_size ((n+1)/2) * 2
 131
 132 let new_table pub_labels =
 133   incr table_count;
 134   let len = Array.length pub_labels in
 135   let methods = Array.create (len*2+2) dummy_met in
 136   methods.(0) <- magic len;
 137   methods.(1) <- magic (fit_size len * Sys.word_size / 8 - 1);
 138   for i = 0 to len - 1 do methods.(i*2+3) <- magic pub_labels.(i) done;
 139   { methods = methods;
 140     methods_by_name = Meths.empty;
 141     methods_by_label = Labs.empty;
 142     previous_states = [];
 143     hidden_meths = [];
 144     vars = Vars.empty;
 145     initializers = [];
 146     size = initial_object_size }
 147
 148 let resize array new_size =
 149   let old_size = Array.length array.methods in
 150   if new_size > old_size then begin
 151     let new_buck = Array.create new_size dummy_met in
 152     Array.blit array.methods 0 new_buck 0 old_size;
 153     array.methods <- new_buck
 154  end
 155
 156 let put array label element =
 157   resize array (label + 1);
 158   array.methods.(label) <- element
 159
 160 (**** Classes ****)
 161
 162 let method_count = ref 0
 163 let inst_var_count = ref 0
 164
 165 (* type t *)
 166 type meth = item
 167
 168 let new_method table =
 169   let index = Array.length table.methods in
 170   resize table (index + 1);
 171   index
 172
 173 let get_method_label table name =
 174   try
 175     Meths.find name table.methods_by_name
 176   with Not_found ->
 177     let label = new_method table in
 178     table.methods_by_name <- Meths.add name label table.methods_by_name;
 179     table.methods_by_label <- Labs.add label true table.methods_by_label;
 180     label
 181
 182 let get_method_labels table names =
 183   Array.map (get_method_label table) names
 184
 185 let set_method table label element =
 186   incr method_count;
 187   if Labs.find label table.methods_by_label then
 188     put table label element
 189   else
 190     table.hidden_meths <- (label, element) :: table.hidden_meths
 191
 192 let get_method table label =
 193   try List.assoc label table.hidden_meths
 194   with Not_found -> table.methods.(label)
 195
 196 let to_list arr =
 197   if arr == magic 0 then [] else Array.to_list arr
 198
 199 let narrow table vars virt_meths concr_meths =
 200   let vars = to_list vars
 201   and virt_meths = to_list virt_meths
 202   and concr_meths = to_list concr_meths in
 203   let virt_meth_labs = List.map (get_method_label table) virt_meths in
 204   let concr_meth_labs = List.map (get_method_label table) concr_meths in
 205   table.previous_states <-
 206      (table.methods_by_name, table.methods_by_label, table.hidden_meths,
 207       table.vars, virt_meth_labs, vars)
 208      :: table.previous_states;
 209   table.vars <-
 210     Vars.fold
 211       (fun lab info tvars ->
 212         if List.mem lab vars then Vars.add lab info tvars else tvars)
 213       table.vars Vars.empty;
 214   let by_name = ref Meths.empty in
 215   let by_label = ref Labs.empty in
 216   List.iter2
 217     (fun met label ->
 218        by_name := Meths.add met label !by_name;
 219        by_label :=
 220           Labs.add label
 221             (try Labs.find label table.methods_by_label with Not_found -> true)
 222             !by_label)
 223     concr_meths concr_meth_labs;
 224   List.iter2
 225     (fun met label ->
 226        by_name := Meths.add met label !by_name;
 227        by_label := Labs.add label false !by_label)
 228     virt_meths virt_meth_labs;
 229   table.methods_by_name <- !by_name;
 230   table.methods_by_label <- !by_label;
 231   table.hidden_meths <-
 232      List.fold_right
 233        (fun ((lab, _) as met) hm ->
 234           if List.mem lab virt_meth_labs then hm else met::hm)
 235        table.hidden_meths
 236        []
 237
 238 let widen table =
 239   let (by_name, by_label, saved_hidden_meths, saved_vars, virt_meths, vars) =
 240     List.hd table.previous_states
 241   in
 242   table.previous_states <- List.tl table.previous_states;
 243   table.vars <-
 244      List.fold_left
 245        (fun s v -> Vars.add v (Vars.find v table.vars) s)
 246        saved_vars vars;
 247   table.methods_by_name <- by_name;
 248   table.methods_by_label <- by_label;
 249   table.hidden_meths <-
 250      List.fold_right
 251        (fun ((lab, _) as met) hm ->
 252           if List.mem lab virt_meths then hm else met::hm)
 253        table.hidden_meths
 254        saved_hidden_meths
 255
 256 let new_slot table =
 257   let index = table.size in
 258   table.size <- index + 1;
 259   index
 260
 261 let new_variable table name =
 262   try Vars.find name table.vars
 263   with Not_found ->
 264     let index = new_slot table in
 265     if name <> "" then table.vars <- Vars.add name index table.vars;
 266     index
 267
 268 let to_array arr =
 269   if arr = Obj.magic 0 then [||] else arr
 270
 271 let new_methods_variables table meths vals =
 272   let meths = to_array meths in
 273   let nmeths = Array.length meths and nvals = Array.length vals in
 274   let res = Array.create (nmeths + nvals) 0 in
 275   for i = 0 to nmeths - 1 do
 276     res.(i) <- get_method_label table meths.(i)
 277   done;
 278   for i = 0 to nvals - 1 do
 279     res.(i+nmeths) <- new_variable table vals.(i)
 280   done;
 281   res
 282
 283 let get_variable table name =
 284   try Vars.find name table.vars with Not_found -> assert false
 285
 286 let get_variables table names =
 287   Array.map (get_variable table) names
 288
 289 let add_initializer table f =
 290   table.initializers <- f::table.initializers
 291
 292 (*
 293 module Keys = Map.Make(struct type t = tag array let compare = compare end)
 294 let key_map = ref Keys.empty
 295 let get_key tags : item =
 296   try magic (Keys.find tags !key_map : tag array)
 297   with Not_found ->
 298     key_map := Keys.add tags tags !key_map;
 299     magic tags
 300 *)
 301
 302 let create_table public_methods =
 303   if public_methods == magic 0 then new_table [||] else
 304   (* [public_methods] must be in ascending order for bytecode *)
 305   let tags = Array.map public_method_label public_methods in
 306   let table = new_table tags in
 307   Array.iteri
 308     (fun i met ->
 309       let lab = i*2+2 in
 310       table.methods_by_name  <- Meths.add met lab table.methods_by_name;
 311       table.methods_by_label <- Labs.add lab true table.methods_by_label)
 312     public_methods;
 313   table
 314
 315 let init_class table =
 316   inst_var_count := !inst_var_count + table.size - 1;
 317   table.initializers <- List.rev table.initializers;
 318   resize table (3 + magic table.methods.(1) * 16 / Sys.word_size)
 319
 320 let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
 321   narrow cla vals virt_meths concr_meths;
 322   let init =
 323     if top then super cla env else Obj.repr (super cla) in
 324   widen cla;
 325   Array.concat
 326     [[| repr init |];
 327      magic (Array.map (get_variable cla) (to_array vals) : int array);
 328      Array.map
 329        (fun nm -> repr (get_method cla (get_method_label cla nm) : closure))
 330        (to_array concr_meths) ]
 331
 332 let make_class pub_meths class_init =
 333   let table = create_table pub_meths in
 334   let env_init = class_init table in
 335   init_class table;
 336   (env_init (Obj.repr 0), class_init, env_init, Obj.repr 0)
 337
 338 type init_table = { mutable env_init: t; mutable class_init: table -> t }
 339
 340 let make_class_store pub_meths class_init init_table =
 341   let table = create_table pub_meths in
 342   let env_init = class_init table in
 343   init_class table;
 344   init_table.class_init <- class_init;
 345   init_table.env_init <- env_init
 346
 347 let dummy_class loc =
 348   let undef = fun _ -> raise (Undefined_recursive_module loc) in
 349   (Obj.magic undef, undef, undef, Obj.repr 0)
 350
 351 (**** Objects ****)
 352
 353 let create_object table =
 354   (* XXX Appel de [obj_block] *)
 355   let obj = Obj.new_block Obj.object_tag table.size in
 356   (* XXX Appel de [caml_modify] *)
 357   Obj.set_field obj 0 (Obj.repr table.methods);
 358   set_id obj last_id;
 359   (Obj.obj obj)
 360
 361 let create_object_opt obj_0 table =
 362   if (Obj.magic obj_0 : bool) then obj_0 else begin
 363     (* XXX Appel de [obj_block] *)
 364     let obj = Obj.new_block Obj.object_tag table.size in
 365     (* XXX Appel de [caml_modify] *)
 366     Obj.set_field obj 0 (Obj.repr table.methods);
 367     set_id obj last_id;
 368     (Obj.obj obj)
 369   end
 370
 371 let rec iter_f obj =
 372   function
 373     []   -> ()
 374   | f::l -> f obj; iter_f obj l
 375
 376 let run_initializers obj table =
 377   let inits = table.initializers in
 378   if inits <> [] then
 379     iter_f obj inits
 380
 381 let run_initializers_opt obj_0 obj table =
 382   if (Obj.magic obj_0 : bool) then obj else begin
 383     let inits = table.initializers in
 384     if inits <> [] then iter_f obj inits;
 385     obj
 386   end
 387
 388 let create_object_and_run_initializers obj_0 table =
 389   if (Obj.magic obj_0 : bool) then obj_0 else begin
 390     let obj = create_object table in
 391     run_initializers obj table;
 392     obj
 393   end
 394
 395 (* Equivalent primitive below
 396 let sendself obj lab =
 397   (magic obj : (obj -> t) array array).(0).(lab) obj
 398 *)
 399 external send : obj -> tag -> 'a = "%send"
 400 external sendcache : obj -> tag -> t -> int -> 'a = "%sendcache"
 401 external sendself : obj -> label -> 'a = "%sendself"
 402 external get_public_method : obj -> tag -> closure
 403     = "caml_get_public_method" "noalloc"
 404
 405 (**** table collection access ****)
 406
 407 type tables = Empty | Cons of closure * tables * tables
 408 type mut_tables =
 409     {key: closure; mutable data: tables; mutable next: tables}
 410 external mut : tables -> mut_tables = "%identity"
 411
 412 let build_path n keys tables =
 413   let res = Cons (Obj.magic 0, Empty, Empty) in
 414   let r = ref res in
 415   for i = 0 to n do
 416     r := Cons (keys.(i), !r, Empty)
 417   done;
 418   tables.data <- !r;
 419   res
 420
 421 let rec lookup_keys i keys tables =
 422   if i < 0 then tables else
 423   let key = keys.(i) in
 424   let rec lookup_key tables =
 425     if tables.key == key then lookup_keys (i-1) keys tables.data else
 426     if tables.next <> Empty then lookup_key (mut tables.next) else
 427     let next = Cons (key, Empty, Empty) in
 428     tables.next <- next;
 429     build_path (i-1) keys (mut next)
 430   in
 431   lookup_key (mut tables)
 432
 433 let lookup_tables root keys =
 434   let root = mut root in
 435   if root.data <> Empty then
 436     lookup_keys (Array.length keys - 1) keys root.data
 437   else
 438     build_path (Array.length keys - 1) keys root
 439
 440 (**** builtin methods ****)
 441
 442 let get_const x = ret (fun obj -> x)
 443 let get_var n   = ret (fun obj -> Array.unsafe_get obj n)
 444 let get_env e n =
 445   ret (fun obj ->
 446     Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n)
 447 let get_meth n  = ret (fun obj -> sendself obj n)
 448 let set_var n   = ret (fun obj x -> Array.unsafe_set obj n x)
 449 let app_const f x = ret (fun obj -> f x)
 450 let app_var f n   = ret (fun obj -> f (Array.unsafe_get obj n))
 451 let app_env f e n =
 452   ret (fun obj ->
 453     f (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n))
 454 let app_meth f n  = ret (fun obj -> f (sendself obj n))
 455 let app_const_const f x y = ret (fun obj -> f x y)
 456 let app_const_var f x n   = ret (fun obj -> f x (Array.unsafe_get obj n))
 457 let app_const_meth f x n = ret (fun obj -> f x (sendself obj n))
 458 let app_var_const f n x = ret (fun obj -> f (Array.unsafe_get obj n) x)
 459 let app_meth_const f n x = ret (fun obj -> f (sendself obj n) x)
 460 let app_const_env f x e n =
 461   ret (fun obj ->
 462     f x (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n))
 463 let app_env_const f e n x =
 464   ret (fun obj ->
 465     f (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n) x)
 466 let meth_app_const n x = ret (fun obj -> (sendself obj n : _ -> _) x)
 467 let meth_app_var n m =
 468   ret (fun obj -> (sendself obj n : _ -> _) (Array.unsafe_get obj m))
 469 let meth_app_env n e m =
 470   ret (fun obj -> (sendself obj n : _ -> _)
 471       (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) m))
 472 let meth_app_meth n m =
 473   ret (fun obj -> (sendself obj n : _ -> _) (sendself obj m))
 474 let send_const m x c =
 475   ret (fun obj -> sendcache x m (Array.unsafe_get obj 0) c)
 476 let send_var m n c =
 477   ret (fun obj ->
 478     sendcache (Obj.magic (Array.unsafe_get obj n) : obj) m
 479       (Array.unsafe_get obj 0) c)
 480 let send_env m e n c =
 481   ret (fun obj ->
 482     sendcache
 483       (Obj.magic (Array.unsafe_get
 484                     (Obj.magic (Array.unsafe_get obj e) : obj) n) : obj)
 485       m (Array.unsafe_get obj 0) c)
 486 let send_meth m n c =
 487   ret (fun obj ->
 488     sendcache (sendself obj n) m (Array.unsafe_get obj 0) c)
 489 let new_cache table =
 490   let n = new_method table in
 491   let n =
 492     if n mod 2 = 0 || n > 2 + magic table.methods.(1) * 16 / Sys.word_size
 493     then n else new_method table
 494   in
 495   table.methods.(n) <- Obj.magic 0;
 496   n
 497
 498 type impl =
 499     GetConst
 500   | GetVar
 501   | GetEnv
 502   | GetMeth
 503   | SetVar
 504   | AppConst
 505   | AppVar
 506   | AppEnv
 507   | AppMeth
 508   | AppConstConst
 509   | AppConstVar
 510   | AppConstEnv
 511   | AppConstMeth
 512   | AppVarConst
 513   | AppEnvConst
 514   | AppMethConst
 515   | MethAppConst
 516   | MethAppVar
 517   | MethAppEnv
 518   | MethAppMeth
 519   | SendConst
 520   | SendVar
 521   | SendEnv
 522   | SendMeth
 523   | Closure of closure
 524
 525 let method_impl table i arr =
 526   let next () = incr i; magic arr.(!i) in
 527   match next() with
 528     GetConst -> let x : t = next() in get_const x
 529   | GetVar   -> let n = next() in get_var n
 530   | GetEnv   -> let e = next() and n = next() in get_env e n
 531   | GetMeth  -> let n = next() in get_meth n
 532   | SetVar   -> let n = next() in set_var n
 533   | AppConst -> let f = next() and x = next() in app_const f x
 534   | AppVar   -> let f = next() and n = next () in app_var f n
 535   | AppEnv   ->
 536       let f = next() and e = next() and n = next() in app_env f e n
 537   | AppMeth  -> let f = next() and n = next () in app_meth f n
 538   | AppConstConst ->
 539       let f = next() and x = next() and y = next() in app_const_const f x y
 540   | AppConstVar ->
 541       let f = next() and x = next() and n = next() in app_const_var f x n
 542   | AppConstEnv ->
 543       let f = next() and x = next() and e = next () and n = next() in
 544       app_const_env f x e n
 545   | AppConstMeth ->
 546       let f = next() and x = next() and n = next() in app_const_meth f x n
 547   | AppVarConst ->
 548       let f = next() and n = next() and x = next() in app_var_const f n x
 549   | AppEnvConst ->
 550       let f = next() and e = next () and n = next() and x = next() in
 551       app_env_const f e n x
 552   | AppMethConst ->
 553       let f = next() and n = next() and x = next() in app_meth_const f n x
 554   | MethAppConst ->
 555       let n = next() and x = next() in meth_app_const n x
 556   | MethAppVar ->
 557       let n = next() and m = next() in meth_app_var n m
 558   | MethAppEnv ->
 559       let n = next() and e = next() and m = next() in meth_app_env n e m
 560   | MethAppMeth ->
 561       let n = next() and m = next() in meth_app_meth n m
 562   | SendConst ->
 563       let m = next() and x = next() in send_const m x (new_cache table)
 564   | SendVar ->
 565       let m = next() and n = next () in send_var m n (new_cache table)
 566   | SendEnv ->
 567       let m = next() and e = next() and n = next() in
 568       send_env m e n (new_cache table)
 569   | SendMeth ->
 570       let m = next() and n = next () in send_meth m n (new_cache table)
 571   | Closure _ as clo -> magic clo
 572
 573 let set_methods table methods =
 574   let len = Array.length methods and i = ref 0 in
 575   while !i < len do
 576     let label = methods.(!i) and clo = method_impl table i methods in
 577     set_method table label clo;
 578     incr i
 579   done
 580
 581 (**** Statistics ****)
 582
 583 type stats =
 584   { classes: int; methods: int; inst_vars: int; }
 585
 586 let stats () =
 587   { classes = !table_count;
 588     methods = !method_count; inst_vars = !inst_var_count; }