1(**************************************************************************) 2(* *) 3(* OCaml *) 4(* *) 5(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) 6(* *) 7(* Copyright 1996 Institut National de Recherche en Informatique et *) 8(* en Automatique. *) 9(* *) 10(* All rights reserved. This file is distributed under the terms of *) 11(* the GNU Lesser General Public License version 2.1, with the *) 12(* special exception on linking described in the file LICENSE. *) 13(* *) 14(**************************************************************************) 15 16open Misc 17open Asttypes 18open Longident 19open Lambda 20 21(* Get oo primitives identifiers *) 22 23let oo_prim name = 24 try 25 transl_normal_path 26 (fst (Env.lookup_value (Ldot (Lident "CamlinternalOO", name)) Env.empty)) 27 with Not_found -> 28 fatal_error ("Primitive " ^ name ^ " not found.") 29 30(* Share blocks *) 31 32let consts : (structured_constant, Ident.t) Hashtbl.t = Hashtbl.create 17 33 34let share c = 35 match c with 36 Const_block (_n, l) when l <> [] -> 37 begin try 38 Lvar (Hashtbl.find consts c) 39 with Not_found -> 40 let id = Ident.create "shared" in 41 Hashtbl.add consts c id; 42 Lvar id 43 end 44 | _ -> Lconst c 45 46(* Collect labels *) 47 48let cache_required = ref false 49let method_cache = ref lambda_unit 50let method_count = ref 0 51let method_table = ref [] 52 53let meth_tag s = Lconst(Const_base(Const_int(Btype.hash_variant s))) 54 55let next_cache tag = 56 let n = !method_count in 57 incr method_count; 58 (tag, [!method_cache; Lconst(Const_base(Const_int n))]) 59 60let rec is_path = function 61 Lvar _ | Lprim (Pgetglobal _, [], _) | Lconst _ -> true 62 | Lprim (Pfield _, [lam], _) -> is_path lam 63 | Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2], _) -> 64 is_path lam1 && is_path lam2 65 | _ -> false 66 67let meth obj lab = 68 let tag = meth_tag lab in 69 if not (!cache_required && !Clflags.native_code) then (tag, []) else 70 if not (is_path obj) then next_cache tag else 71 try 72 let r = List.assoc obj !method_table in 73 try 74 (tag, List.assoc tag !r) 75 with Not_found -> 76 let p = next_cache tag in 77 r := p :: !r; 78 p 79 with Not_found -> 80 let p = next_cache tag in 81 method_table := (obj, ref [p]) :: !method_table; 82 p 83 84let reset_labels () = 85 Hashtbl.clear consts; 86 method_count := 0; 87 method_table := [] 88 89(* Insert labels *) 90 91let int n = Lconst (Const_base (Const_int n)) 92 93let prim_makearray = 94 Primitive.simple ~name:"caml_make_vect" ~arity:2 ~alloc:true 95 96(* Also use it for required globals *) 97let transl_label_init_general f = 98 let expr, size = f () in 99 let expr = 100 Hashtbl.fold 101 (fun c id expr -> Llet(Alias, Pgenval, id, Lconst c, expr)) 102 consts expr 103 in 104 (*let expr = 105 List.fold_right 106 (fun id expr -> Lsequence(Lprim(Pgetglobal id, [], Location.none), expr)) 107 (Env.get_required_globals ()) expr 108 in 109 Env.reset_required_globals ();*) 110 reset_labels (); 111 expr, size 112 113let transl_label_init_flambda f = 114 assert(Config.flambda); 115 let method_cache_id = Ident.create "method_cache" in 116 method_cache := Lvar method_cache_id; 117 (* Calling f (usualy Translmod.transl_struct) requires the 118 method_cache variable to be initialised to be able to generate 119 method accesses. *) 120 let expr, size = f () in 121 let expr = 122 if !method_count = 0 then expr 123 else 124 Llet (Strict, Pgenval, method_cache_id, 125 Lprim (Pccall prim_makearray, 126 [int !method_count; int 0], 127 Location.none), 128 expr) 129 in 130 transl_label_init_general (fun () -> expr, size) 131 132let transl_store_label_init glob size f arg = 133 assert(not Config.flambda); 134 assert(!Clflags.native_code); 135 method_cache := Lprim(Pfield size, 136 [Lprim(Pgetglobal glob, [], Location.none)], 137 Location.none); 138 let expr = f arg in 139 let (size, expr) = 140 if !method_count = 0 then (size, expr) else 141 (size+1, 142 Lsequence( 143 Lprim(Psetfield(size, Pointer, Root_initialization), 144 [Lprim(Pgetglobal glob, [], Location.none); 145 Lprim (Pccall prim_makearray, 146 [int !method_count; int 0], 147 Location.none)], 148 Location.none), 149 expr)) 150 in 151 let lam, size = transl_label_init_general (fun () -> (expr, size)) in 152 size, lam 153 154let transl_label_init f = 155 if !Clflags.native_code then 156 transl_label_init_flambda f 157 else 158 transl_label_init_general f 159 160(* Share classes *) 161 162let wrapping = ref false 163let top_env = ref Env.empty 164let classes = ref [] 165let method_ids = ref IdentSet.empty 166 167let oo_add_class id = 168 classes := id :: !classes; 169 (!top_env, !cache_required) 170 171let oo_wrap env req f x = 172 if !wrapping then 173 if !cache_required then f x else 174 try cache_required := true; let lam = f x in cache_required := false; lam 175 with exn -> cache_required := false; raise exn 176 else try 177 wrapping := true; 178 cache_required := req; 179 top_env := env; 180 classes := []; 181 method_ids := IdentSet.empty; 182 let lambda = f x in 183 let lambda = 184 List.fold_left 185 (fun lambda id -> 186 Llet(StrictOpt, Pgenval, id, 187 Lprim(Pmakeblock(0, Mutable, None), 188 [lambda_unit; lambda_unit; lambda_unit], 189 Location.none), 190 lambda)) 191 lambda !classes 192 in 193 wrapping := false; 194 top_env := Env.empty; 195 lambda 196 with exn -> 197 wrapping := false; 198 top_env := Env.empty; 199 raise exn 200 201let reset () = 202 Hashtbl.clear consts; 203 cache_required := false; 204 method_cache := lambda_unit; 205 method_count := 0; 206 method_table := []; 207 wrapping := false; 208 top_env := Env.empty; 209 classes := []; 210 method_ids := IdentSet.empty 211