1(**************************************************************************) 2(* *) 3(* OCaml *) 4(* *) 5(* Xavier Leroy, 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 16(* Translation from typed abstract syntax to lambda terms, 17 for the core language *) 18 19open Misc 20open Asttypes 21open Primitive 22open Types 23open Typedtree 24open Typeopt 25open Lambda 26 27type error = 28 Illegal_letrec_pat 29 | Illegal_letrec_expr 30 | Free_super_var 31 | Unknown_builtin_primitive of string 32 | Unreachable_reached 33 34exception Error of Location.t * error 35 36let use_dup_for_constant_arrays_bigger_than = 4 37 38(* Forward declaration -- to be filled in by Translmod.transl_module *) 39let transl_module = 40 ref((fun _cc _rootpath _modl -> assert false) : 41 module_coercion -> Path.t option -> module_expr -> lambda) 42 43let transl_object = 44 ref (fun _id _s _cl -> assert false : 45 Ident.t -> string list -> class_expr -> lambda) 46 47(* Compile an exception/extension definition *) 48 49let prim_fresh_oo_id = 50 Pccall (Primitive.simple ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false) 51 52let transl_extension_constructor env path ext = 53 let name = 54 match path, !Clflags.for_package with 55 None, _ -> Ident.name ext.ext_id 56 | Some p, None -> Path.name p 57 | Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p) 58 in 59 let loc = ext.ext_loc in 60 match ext.ext_kind with 61 Text_decl _ -> 62 Lprim (Pmakeblock (Obj.object_tag, Immutable, None), 63 [Lconst (Const_base (Const_string (name, None))); 64 Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)], 65 loc) 66 | Text_rebind(path, _lid) -> 67 transl_path ~loc env path 68 69(* Translation of primitives *) 70 71let comparisons_table = create_hashtable 11 [ 72 "%equal", 73 (Pccall(Primitive.simple ~name:"caml_equal" ~arity:2 ~alloc:true), 74 Pintcomp Ceq, 75 Pfloatcomp Ceq, 76 Pccall(Primitive.simple ~name:"caml_string_equal" ~arity:2 77 ~alloc:false), 78 Pccall(Primitive.simple ~name:"caml_bytes_equal" ~arity:2 79 ~alloc:false), 80 Pbintcomp(Pnativeint, Ceq), 81 Pbintcomp(Pint32, Ceq), 82 Pbintcomp(Pint64, Ceq), 83 true); 84 "%notequal", 85 (Pccall(Primitive.simple ~name:"caml_notequal" ~arity:2 ~alloc:true), 86 Pintcomp Cneq, 87 Pfloatcomp Cneq, 88 Pccall(Primitive.simple ~name:"caml_string_notequal" ~arity:2 89 ~alloc:false), 90 Pccall(Primitive.simple ~name:"caml_bytes_notequal" ~arity:2 91 ~alloc:false), 92 Pbintcomp(Pnativeint, Cneq), 93 Pbintcomp(Pint32, Cneq), 94 Pbintcomp(Pint64, Cneq), 95 true); 96 "%lessthan", 97 (Pccall(Primitive.simple ~name:"caml_lessthan" ~arity:2 ~alloc:true), 98 Pintcomp Clt, 99 Pfloatcomp Clt, 100 Pccall(Primitive.simple ~name:"caml_string_lessthan" ~arity:2 101 ~alloc:false), 102 Pccall(Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2 103 ~alloc:false), 104 Pbintcomp(Pnativeint, Clt), 105 Pbintcomp(Pint32, Clt), 106 Pbintcomp(Pint64, Clt), 107 false); 108 "%greaterthan", 109 (Pccall(Primitive.simple ~name:"caml_greaterthan" ~arity:2 ~alloc:true), 110 Pintcomp Cgt, 111 Pfloatcomp Cgt, 112 Pccall(Primitive.simple ~name:"caml_string_greaterthan" ~arity:2 113 ~alloc: false), 114 Pccall(Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2 115 ~alloc: false), 116 Pbintcomp(Pnativeint, Cgt), 117 Pbintcomp(Pint32, Cgt), 118 Pbintcomp(Pint64, Cgt), 119 false); 120 "%lessequal", 121 (Pccall(Primitive.simple ~name:"caml_lessequal" ~arity:2 ~alloc:true), 122 Pintcomp Cle, 123 Pfloatcomp Cle, 124 Pccall(Primitive.simple ~name:"caml_string_lessequal" ~arity:2 125 ~alloc:false), 126 Pccall(Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2 127 ~alloc:false), 128 Pbintcomp(Pnativeint, Cle), 129 Pbintcomp(Pint32, Cle), 130 Pbintcomp(Pint64, Cle), 131 false); 132 "%greaterequal", 133 (Pccall(Primitive.simple ~name:"caml_greaterequal" ~arity:2 ~alloc:true), 134 Pintcomp Cge, 135 Pfloatcomp Cge, 136 Pccall(Primitive.simple ~name:"caml_string_greaterequal" ~arity:2 137 ~alloc:false), 138 Pccall(Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2 139 ~alloc:false), 140 Pbintcomp(Pnativeint, Cge), 141 Pbintcomp(Pint32, Cge), 142 Pbintcomp(Pint64, Cge), 143 false); 144 "%compare", 145 let unboxed_compare name native_repr = 146 Pccall( Primitive.make ~name ~alloc:false 147 ~native_name:(name^"_unboxed") 148 ~native_repr_args:[native_repr;native_repr] 149 ~native_repr_res:Untagged_int 150 ) in 151 (Pccall(Primitive.simple ~name:"caml_compare" ~arity:2 ~alloc:true), 152 (* Not unboxed since the comparison is done directly on tagged int *) 153 Pccall(Primitive.simple ~name:"caml_int_compare" ~arity:2 ~alloc:false), 154 unboxed_compare "caml_float_compare" Unboxed_float, 155 Pccall(Primitive.simple ~name:"caml_string_compare" ~arity:2 156 ~alloc:false), 157 Pccall(Primitive.simple ~name:"caml_bytes_compare" ~arity:2 158 ~alloc:false), 159 unboxed_compare "caml_nativeint_compare" (Unboxed_integer Pnativeint), 160 unboxed_compare "caml_int32_compare" (Unboxed_integer Pint32), 161 unboxed_compare "caml_int64_compare" (Unboxed_integer Pint64), 162 false) 163] 164 165let primitives_table = create_hashtable 57 [ 166 "%identity", Pidentity; 167 "%bytes_to_string", Pbytes_to_string; 168 "%bytes_of_string", Pbytes_of_string; 169 "%ignore", Pignore; 170 "%revapply", Prevapply; 171 "%apply", Pdirapply; 172 "%loc_LOC", Ploc Loc_LOC; 173 "%loc_FILE", Ploc Loc_FILE; 174 "%loc_LINE", Ploc Loc_LINE; 175 "%loc_POS", Ploc Loc_POS; 176 "%loc_MODULE", Ploc Loc_MODULE; 177 "%field0", Pfield 0; 178 "%field1", Pfield 1; 179 "%setfield0", Psetfield(0, Pointer, Assignment); 180 "%makeblock", Pmakeblock(0, Immutable, None); 181 "%makemutable", Pmakeblock(0, Mutable, None); 182 "%raise", Praise Raise_regular; 183 "%reraise", Praise Raise_reraise; 184 "%raise_notrace", Praise Raise_notrace; 185 "%sequand", Psequand; 186 "%sequor", Psequor; 187 "%boolnot", Pnot; 188 "%big_endian", Pctconst Big_endian; 189 "%backend_type", Pctconst Backend_type; 190 "%word_size", Pctconst Word_size; 191 "%int_size", Pctconst Int_size; 192 "%max_wosize", Pctconst Max_wosize; 193 "%ostype_unix", Pctconst Ostype_unix; 194 "%ostype_win32", Pctconst Ostype_win32; 195 "%ostype_cygwin", Pctconst Ostype_cygwin; 196 "%negint", Pnegint; 197 "%succint", Poffsetint 1; 198 "%predint", Poffsetint(-1); 199 "%addint", Paddint; 200 "%subint", Psubint; 201 "%mulint", Pmulint; 202 "%divint", Pdivint Safe; 203 "%modint", Pmodint Safe; 204 "%andint", Pandint; 205 "%orint", Porint; 206 "%xorint", Pxorint; 207 "%lslint", Plslint; 208 "%lsrint", Plsrint; 209 "%asrint", Pasrint; 210 "%eq", Pintcomp Ceq; 211 "%noteq", Pintcomp Cneq; 212 "%ltint", Pintcomp Clt; 213 "%leint", Pintcomp Cle; 214 "%gtint", Pintcomp Cgt; 215 "%geint", Pintcomp Cge; 216 "%incr", Poffsetref(1); 217 "%decr", Poffsetref(-1); 218 "%intoffloat", Pintoffloat; 219 "%floatofint", Pfloatofint; 220 "%negfloat", Pnegfloat; 221 "%absfloat", Pabsfloat; 222 "%addfloat", Paddfloat; 223 "%subfloat", Psubfloat; 224 "%mulfloat", Pmulfloat; 225 "%divfloat", Pdivfloat; 226 "%eqfloat", Pfloatcomp Ceq; 227 "%noteqfloat", Pfloatcomp Cneq; 228 "%ltfloat", Pfloatcomp Clt; 229 "%lefloat", Pfloatcomp Cle; 230 "%gtfloat", Pfloatcomp Cgt; 231 "%gefloat", Pfloatcomp Cge; 232 "%string_length", Pstringlength; 233 "%string_safe_get", Pstringrefs; 234 "%string_safe_set", Pbytessets; 235 "%string_unsafe_get", Pstringrefu; 236 "%string_unsafe_set", Pbytessetu; 237 "%bytes_length", Pbyteslength; 238 "%bytes_safe_get", Pbytesrefs; 239 "%bytes_safe_set", Pbytessets; 240 "%bytes_unsafe_get", Pbytesrefu; 241 "%bytes_unsafe_set", Pbytessetu; 242 "%array_length", Parraylength Pgenarray; 243 "%array_safe_get", Parrayrefs Pgenarray; 244 "%array_safe_set", Parraysets Pgenarray; 245 "%array_unsafe_get", Parrayrefu Pgenarray; 246 "%array_unsafe_set", Parraysetu Pgenarray; 247 "%obj_size", Parraylength Pgenarray; 248 "%obj_field", Parrayrefu Pgenarray; 249 "%obj_set_field", Parraysetu Pgenarray; 250 "%obj_is_int", Pisint; 251 "%lazy_force", Plazyforce; 252 "%nativeint_of_int", Pbintofint Pnativeint; 253 "%nativeint_to_int", Pintofbint Pnativeint; 254 "%nativeint_neg", Pnegbint Pnativeint; 255 "%nativeint_add", Paddbint Pnativeint; 256 "%nativeint_sub", Psubbint Pnativeint; 257 "%nativeint_mul", Pmulbint Pnativeint; 258 "%nativeint_div", Pdivbint { size = Pnativeint; is_safe = Safe }; 259 "%nativeint_mod", Pmodbint { size = Pnativeint; is_safe = Safe }; 260 "%nativeint_and", Pandbint Pnativeint; 261 "%nativeint_or", Porbint Pnativeint; 262 "%nativeint_xor", Pxorbint Pnativeint; 263 "%nativeint_lsl", Plslbint Pnativeint; 264 "%nativeint_lsr", Plsrbint Pnativeint; 265 "%nativeint_asr", Pasrbint Pnativeint; 266 "%int32_of_int", Pbintofint Pint32; 267 "%int32_to_int", Pintofbint Pint32; 268 "%int32_neg", Pnegbint Pint32; 269 "%int32_add", Paddbint Pint32; 270 "%int32_sub", Psubbint Pint32; 271 "%int32_mul", Pmulbint Pint32; 272 "%int32_div", Pdivbint { size = Pint32; is_safe = Safe }; 273 "%int32_mod", Pmodbint { size = Pint32; is_safe = Safe }; 274 "%int32_and", Pandbint Pint32; 275 "%int32_or", Porbint Pint32; 276 "%int32_xor", Pxorbint Pint32; 277 "%int32_lsl", Plslbint Pint32; 278 "%int32_lsr", Plsrbint Pint32; 279 "%int32_asr", Pasrbint Pint32; 280 "%int64_of_int", Pbintofint Pint64; 281 "%int64_to_int", Pintofbint Pint64; 282 "%int64_neg", Pnegbint Pint64; 283 "%int64_add", Paddbint Pint64; 284 "%int64_sub", Psubbint Pint64; 285 "%int64_mul", Pmulbint Pint64; 286 "%int64_div", Pdivbint { size = Pint64; is_safe = Safe }; 287 "%int64_mod", Pmodbint { size = Pint64; is_safe = Safe }; 288 "%int64_and", Pandbint Pint64; 289 "%int64_or", Porbint Pint64; 290 "%int64_xor", Pxorbint Pint64; 291 "%int64_lsl", Plslbint Pint64; 292 "%int64_lsr", Plsrbint Pint64; 293 "%int64_asr", Pasrbint Pint64; 294 "%nativeint_of_int32", Pcvtbint(Pint32, Pnativeint); 295 "%nativeint_to_int32", Pcvtbint(Pnativeint, Pint32); 296 "%int64_of_int32", Pcvtbint(Pint32, Pint64); 297 "%int64_to_int32", Pcvtbint(Pint64, Pint32); 298 "%int64_of_nativeint", Pcvtbint(Pnativeint, Pint64); 299 "%int64_to_nativeint", Pcvtbint(Pint64, Pnativeint); 300 "%caml_ba_ref_1", 301 Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout); 302 "%caml_ba_ref_2", 303 Pbigarrayref(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout); 304 "%caml_ba_ref_3", 305 Pbigarrayref(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout); 306 "%caml_ba_set_1", 307 Pbigarrayset(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout); 308 "%caml_ba_set_2", 309 Pbigarrayset(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout); 310 "%caml_ba_set_3", 311 Pbigarrayset(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout); 312 "%caml_ba_unsafe_ref_1", 313 Pbigarrayref(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout); 314 "%caml_ba_unsafe_ref_2", 315 Pbigarrayref(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout); 316 "%caml_ba_unsafe_ref_3", 317 Pbigarrayref(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout); 318 "%caml_ba_unsafe_set_1", 319 Pbigarrayset(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout); 320 "%caml_ba_unsafe_set_2", 321 Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout); 322 "%caml_ba_unsafe_set_3", 323 Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout); 324 "%caml_ba_dim_1", Pbigarraydim(1); 325 "%caml_ba_dim_2", Pbigarraydim(2); 326 "%caml_ba_dim_3", Pbigarraydim(3); 327 "%caml_string_get16", Pstring_load_16(false); 328 "%caml_string_get16u", Pstring_load_16(true); 329 "%caml_string_get32", Pstring_load_32(false); 330 "%caml_string_get32u", Pstring_load_32(true); 331 "%caml_string_get64", Pstring_load_64(false); 332 "%caml_string_get64u", Pstring_load_64(true); 333 "%caml_string_set16", Pstring_set_16(false); 334 "%caml_string_set16u", Pstring_set_16(true); 335 "%caml_string_set32", Pstring_set_32(false); 336 "%caml_string_set32u", Pstring_set_32(true); 337 "%caml_string_set64", Pstring_set_64(false); 338 "%caml_string_set64u", Pstring_set_64(true); 339 "%caml_bigstring_get16", Pbigstring_load_16(false); 340 "%caml_bigstring_get16u", Pbigstring_load_16(true); 341 "%caml_bigstring_get32", Pbigstring_load_32(false); 342 "%caml_bigstring_get32u", Pbigstring_load_32(true); 343 "%caml_bigstring_get64", Pbigstring_load_64(false); 344 "%caml_bigstring_get64u", Pbigstring_load_64(true); 345 "%caml_bigstring_set16", Pbigstring_set_16(false); 346 "%caml_bigstring_set16u", Pbigstring_set_16(true); 347 "%caml_bigstring_set32", Pbigstring_set_32(false); 348 "%caml_bigstring_set32u", Pbigstring_set_32(true); 349 "%caml_bigstring_set64", Pbigstring_set_64(false); 350 "%caml_bigstring_set64u", Pbigstring_set_64(true); 351 "%bswap16", Pbswap16; 352 "%bswap_int32", Pbbswap(Pint32); 353 "%bswap_int64", Pbbswap(Pint64); 354 "%bswap_native", Pbbswap(Pnativeint); 355 "%int_as_pointer", Pint_as_pointer; 356 "%opaque", Popaque; 357] 358 359let find_primitive prim_name = 360 Hashtbl.find primitives_table prim_name 361 362let prim_restore_raw_backtrace = 363 Primitive.simple ~name:"caml_restore_raw_backtrace" ~arity:2 ~alloc:false 364 365let specialize_comparison table env ty = 366 let (gencomp, intcomp, floatcomp, stringcomp, bytescomp, 367 nativeintcomp, int32comp, int64comp, _) = table in 368 match () with 369 | () when is_base_type env ty Predef.path_int 370 || is_base_type env ty Predef.path_char 371 || (maybe_pointer_type env ty = Immediate) -> intcomp 372 | () when is_base_type env ty Predef.path_float -> floatcomp 373 | () when is_base_type env ty Predef.path_string -> stringcomp 374 | () when is_base_type env ty Predef.path_bytes -> bytescomp 375 | () when is_base_type env ty Predef.path_nativeint -> nativeintcomp 376 | () when is_base_type env ty Predef.path_int32 -> int32comp 377 | () when is_base_type env ty Predef.path_int64 -> int64comp 378 | () -> gencomp 379 380(* Specialize a primitive from available type information, 381 raise Not_found if primitive is unknown *) 382 383let specialize_primitive p env ty ~has_constant_constructor = 384 try 385 let table = Hashtbl.find comparisons_table p.prim_name in 386 let (gencomp, intcomp, _, _, _, _, _, _, simplify_constant_constructor) = 387 table in 388 if has_constant_constructor && simplify_constant_constructor then 389 intcomp 390 else 391 match is_function_type env ty with 392 | Some (lhs,_rhs) -> specialize_comparison table env lhs 393 | None -> gencomp 394 with Not_found -> 395 let p = find_primitive p.prim_name in 396 (* Try strength reduction based on the type of the argument *) 397 let params = match is_function_type env ty with 398 | None -> [] 399 | Some (p1, rhs) -> match is_function_type env rhs with 400 | None -> [p1] 401 | Some (p2, _) -> [p1;p2] 402 in 403 match (p, params) with 404 (Psetfield(n, _, init), [_p1; p2]) -> 405 Psetfield(n, maybe_pointer_type env p2, init) 406 | (Parraylength Pgenarray, [p]) -> Parraylength(array_type_kind env p) 407 | (Parrayrefu Pgenarray, p1 :: _) -> Parrayrefu(array_type_kind env p1) 408 | (Parraysetu Pgenarray, p1 :: _) -> Parraysetu(array_type_kind env p1) 409 | (Parrayrefs Pgenarray, p1 :: _) -> Parrayrefs(array_type_kind env p1) 410 | (Parraysets Pgenarray, p1 :: _) -> Parraysets(array_type_kind env p1) 411 | (Pbigarrayref(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout), 412 p1 :: _) -> 413 let (k, l) = bigarray_type_kind_and_layout env p1 in 414 Pbigarrayref(unsafe, n, k, l) 415 | (Pbigarrayset(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout), 416 p1 :: _) -> 417 let (k, l) = bigarray_type_kind_and_layout env p1 in 418 Pbigarrayset(unsafe, n, k, l) 419 | (Pmakeblock(tag, mut, None), fields) -> 420 let shape = List.map (Typeopt.value_kind env) fields in 421 Pmakeblock(tag, mut, Some shape) 422 | _ -> p 423 424(* Eta-expand a primitive *) 425 426let used_primitives = Hashtbl.create 7 427let add_used_primitive loc env path = 428 match path with 429 Some (Path.Pdot _ as path) -> 430 let path = Env.normalize_path (Some loc) env path in 431 let unit = Path.head path in 432 if Ident.global unit && not (Hashtbl.mem used_primitives path) 433 then Hashtbl.add used_primitives path loc 434 | _ -> () 435 436let transl_primitive loc p env ty path = 437 let prim = 438 try specialize_primitive p env ty ~has_constant_constructor:false 439 with Not_found -> 440 add_used_primitive loc env path; 441 Pccall p 442 in 443 match prim with 444 | Plazyforce -> 445 let parm = Ident.create "prim" in 446 Lfunction{kind = Curried; params = [parm]; 447 body = Matching.inline_lazy_force (Lvar parm) Location.none; 448 loc = loc; 449 attr = default_stub_attribute } 450 | Ploc kind -> 451 let lam = lam_of_loc kind loc in 452 begin match p.prim_arity with 453 | 0 -> lam 454 | 1 -> (* TODO: we should issue a warning ? *) 455 let param = Ident.create "prim" in 456 Lfunction{kind = Curried; params = [param]; 457 attr = default_stub_attribute; 458 loc = loc; 459 body = Lprim(Pmakeblock(0, Immutable, None), 460 [lam; Lvar param], loc)} 461 | _ -> assert false 462 end 463 | _ -> 464 let rec make_params n = 465 if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in 466 let params = make_params p.prim_arity in 467 Lfunction{ kind = Curried; params; 468 attr = default_stub_attribute; 469 loc = loc; 470 body = Lprim(prim, List.map (fun id -> Lvar id) params, loc) } 471 472let transl_primitive_application loc prim env ty path args = 473 let prim_name = prim.prim_name in 474 try 475 let has_constant_constructor = match args with 476 [_; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}] 477 | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}; _] 478 | [_; {exp_desc = Texp_variant(_, None)}] 479 | [{exp_desc = Texp_variant(_, None)}; _] -> true 480 | _ -> false 481 in 482 specialize_primitive prim env ty ~has_constant_constructor 483 with Not_found -> 484 if String.length prim_name > 0 && prim_name.[0] = '%' then 485 raise(Error(loc, Unknown_builtin_primitive prim_name)); 486 add_used_primitive loc env path; 487 Pccall prim 488 489 490(* To check the well-formedness of r.h.s. of "let rec" definitions *) 491 492let check_recursive_lambda idlist lam = 493 let rec check_top idlist = function 494 | Lvar v -> not (List.mem v idlist) 495 | Llet _ as lam when check_recursive_recordwith idlist lam -> 496 true 497 | Llet(_str, _k, id, arg, body) -> 498 check idlist arg && check_top (add_let id arg idlist) body 499 | Lletrec(bindings, body) -> 500 let idlist' = add_letrec bindings idlist in 501 List.for_all (fun (_id, arg) -> check idlist' arg) bindings && 502 check_top idlist' body 503 | Lprim (Pmakearray (Pgenarray, _), _, _) -> false 504 | Lprim (Pmakearray (Pfloatarray, _), args, _) -> 505 List.for_all (check idlist) args 506 | Lsequence (lam1, lam2) -> check idlist lam1 && check_top idlist lam2 507 | Levent (lam, _) -> check_top idlist lam 508 | lam -> check idlist lam 509 510 and check idlist = function 511 | Lvar _ -> true 512 | Lfunction _ -> true 513 | Llet _ as lam when check_recursive_recordwith idlist lam -> 514 true 515 | Llet(_str, _k, id, arg, body) -> 516 check idlist arg && check (add_let id arg idlist) body 517 | Lletrec(bindings, body) -> 518 let idlist' = add_letrec bindings idlist in 519 List.for_all (fun (_id, arg) -> check idlist' arg) bindings && 520 check idlist' body 521 | Lprim(Pmakeblock _, args, _) -> 522 List.for_all (check idlist) args 523 | Lprim (Pmakearray (Pfloatarray, _), _, _) -> false 524 | Lprim (Pmakearray _, args, _) -> 525 List.for_all (check idlist) args 526 | Lsequence (lam1, lam2) -> check idlist lam1 && check idlist lam2 527 | Levent (lam, _) -> check idlist lam 528 | lam -> 529 let fv = free_variables lam in 530 not (List.exists (fun id -> IdentSet.mem id fv) idlist) 531 532 and add_let id arg idlist = 533 let fv = free_variables arg in 534 if List.exists (fun id -> IdentSet.mem id fv) idlist 535 then id :: idlist 536 else idlist 537 538 and add_letrec bindings idlist = 539 List.fold_right (fun (id, arg) idl -> add_let id arg idl) 540 bindings idlist 541 542 (* reverse-engineering the code generated by transl_record case 2 *) 543 (* If you change this, you probably need to change Bytegen.size_of_lambda. *) 544 and check_recursive_recordwith idlist = function 545 | Llet (Strict, _k, id1, Lprim (Pduprecord _, [e1], _), body) -> 546 check_top idlist e1 547 && check_recordwith_updates idlist id1 body 548 | _ -> false 549 550 and check_recordwith_updates idlist id1 = function 551 | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; e1], _), 552 cont) 553 -> id2 = id1 && check idlist e1 554 && check_recordwith_updates idlist id1 cont 555 | Lvar id2 -> id2 = id1 556 | _ -> false 557 558 in check_top idlist lam 559 560(* To propagate structured constants *) 561 562exception Not_constant 563 564let extract_constant = function 565 Lconst sc -> sc 566 | _ -> raise Not_constant 567 568let extract_float = function 569 Const_base(Const_float f) -> f 570 | _ -> fatal_error "Translcore.extract_float" 571 572(* Push the default values under the functional abstractions *) 573(* Also push bindings of module patterns, since this sound *) 574 575type binding = 576 | Bind_value of value_binding list 577 | Bind_module of Ident.t * string loc * module_expr 578 579let rec push_defaults loc bindings cases partial = 580 match cases with 581 [{c_lhs=pat; c_guard=None; 582 c_rhs={exp_desc = Texp_function { arg_label; param; cases; partial; } } 583 as exp}] -> 584 let cases = push_defaults exp.exp_loc bindings cases partial in 585 [{c_lhs=pat; c_guard=None; 586 c_rhs={exp with exp_desc = Texp_function { arg_label; param; cases; 587 partial; }}}] 588 | [{c_lhs=pat; c_guard=None; 589 c_rhs={exp_attributes=[{txt="#default"},_]; 590 exp_desc = Texp_let 591 (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] -> 592 push_defaults loc (Bind_value binds :: bindings) 593 [{c_lhs=pat;c_guard=None;c_rhs=e2}] 594 partial 595 | [{c_lhs=pat; c_guard=None; 596 c_rhs={exp_attributes=[{txt="#modulepat"},_]; 597 exp_desc = Texp_letmodule 598 (id, name, mexpr, ({exp_desc = Texp_function _} as e2))}}] -> 599 push_defaults loc (Bind_module (id, name, mexpr) :: bindings) 600 [{c_lhs=pat;c_guard=None;c_rhs=e2}] 601 partial 602 | [case] -> 603 let exp = 604 List.fold_left 605 (fun exp binds -> 606 {exp with exp_desc = 607 match binds with 608 | Bind_value binds -> Texp_let(Nonrecursive, binds, exp) 609 | Bind_module (id, name, mexpr) -> 610 Texp_letmodule (id, name, mexpr, exp)}) 611 case.c_rhs bindings 612 in 613 [{case with c_rhs=exp}] 614 | {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] -> 615 let param = Typecore.name_pattern "param" cases in 616 let name = Ident.name param in 617 let exp = 618 { exp with exp_loc = loc; exp_desc = 619 Texp_match 620 ({exp with exp_type = pat.pat_type; exp_desc = 621 Texp_ident (Path.Pident param, mknoloc (Longident.Lident name), 622 {val_type = pat.pat_type; val_kind = Val_reg; 623 val_attributes = []; 624 Types.val_loc = Location.none; 625 })}, 626 cases, [], partial) } 627 in 628 push_defaults loc bindings 629 [{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)}; 630 c_guard=None; c_rhs=exp}] 631 Total 632 | _ -> 633 cases 634 635(* Insertion of debugging events *) 636 637let event_before exp lam = match lam with 638| Lstaticraise (_,_) -> lam 639| _ -> 640 if !Clflags.debug && not !Clflags.native_code 641 then Levent(lam, {lev_loc = exp.exp_loc; 642 lev_kind = Lev_before; 643 lev_repr = None; 644 lev_env = Env.summary exp.exp_env}) 645 else lam 646 647let event_after exp lam = 648 if !Clflags.debug && not !Clflags.native_code 649 then Levent(lam, {lev_loc = exp.exp_loc; 650 lev_kind = Lev_after exp.exp_type; 651 lev_repr = None; 652 lev_env = Env.summary exp.exp_env}) 653 else lam 654 655let event_function exp lam = 656 if !Clflags.debug && not !Clflags.native_code then 657 let repr = Some (ref 0) in 658 let (info, body) = lam repr in 659 (info, 660 Levent(body, {lev_loc = exp.exp_loc; 661 lev_kind = Lev_function; 662 lev_repr = repr; 663 lev_env = Env.summary exp.exp_env})) 664 else 665 lam None 666 667let primitive_is_ccall = function 668 (* Determine if a primitive is a Pccall or will be turned later into 669 a C function call that may raise an exception *) 670 | Pccall _ | Pstringrefs | Pbytesrefs | Pbytessets | Parrayrefs _ | 671 Parraysets _ | Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply | 672 Prevapply -> true 673 | _ -> false 674 675(* Assertions *) 676 677let assert_failed exp = 678 let (fname, line, char) = 679 Location.get_pos_info exp.exp_loc.Location.loc_start in 680 Lprim(Praise Raise_regular, [event_after exp 681 (Lprim(Pmakeblock(0, Immutable, None), 682 [transl_normal_path Predef.path_assert_failure; 683 Lconst(Const_block(0, 684 [Const_base(Const_string (fname, None)); 685 Const_base(Const_int line); 686 Const_base(Const_int char)]))], exp.exp_loc))], exp.exp_loc) 687;; 688 689let rec cut n l = 690 if n = 0 then ([],l) else 691 match l with [] -> failwith "Translcore.cut" 692 | a::l -> let (l1,l2) = cut (n-1) l in (a::l1,l2) 693 694(* Translation of expressions *) 695 696let try_ids = Hashtbl.create 8 697 698let rec transl_exp e = 699 List.iter (Translattribute.check_attribute e) e.exp_attributes; 700 let eval_once = 701 (* Whether classes for immediate objects must be cached *) 702 match e.exp_desc with 703 Texp_function _ | Texp_for _ | Texp_while _ -> false 704 | _ -> true 705 in 706 if eval_once then transl_exp0 e else 707 Translobj.oo_wrap e.exp_env true transl_exp0 e 708 709and transl_exp0 e = 710 match e.exp_desc with 711 Texp_ident(path, _, {val_kind = Val_prim p}) -> 712 let public_send = p.prim_name = "%send" in 713 if public_send || p.prim_name = "%sendself" then 714 let kind = if public_send then Public else Self in 715 let obj = Ident.create "obj" and meth = Ident.create "meth" in 716 Lfunction{kind = Curried; params = [obj; meth]; 717 attr = default_stub_attribute; 718 loc = e.exp_loc; 719 body = Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc)} 720 else if p.prim_name = "%sendcache" then 721 let obj = Ident.create "obj" and meth = Ident.create "meth" in 722 let cache = Ident.create "cache" and pos = Ident.create "pos" in 723 Lfunction{kind = Curried; params = [obj; meth; cache; pos]; 724 attr = default_stub_attribute; 725 loc = e.exp_loc; 726 body = Lsend(Cached, Lvar meth, Lvar obj, 727 [Lvar cache; Lvar pos], e.exp_loc)} 728 else 729 transl_primitive e.exp_loc p e.exp_env e.exp_type (Some path) 730 | Texp_ident(_, _, {val_kind = Val_anc _}) -> 731 raise(Error(e.exp_loc, Free_super_var)) 732 | Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) -> 733 transl_path ~loc:e.exp_loc e.exp_env path 734 | Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident" 735 | Texp_constant cst -> 736 Lconst(Const_base cst) 737 | Texp_let(rec_flag, pat_expr_list, body) -> 738 transl_let rec_flag pat_expr_list (event_before body (transl_exp body)) 739 | Texp_function { arg_label = _; param; cases; partial; } -> 740 let ((kind, params), body) = 741 event_function e 742 (function repr -> 743 let pl = push_defaults e.exp_loc [] cases partial in 744 transl_function e.exp_loc !Clflags.native_code repr partial 745 param pl) 746 in 747 let attr = { 748 default_function_attribute with 749 inline = Translattribute.get_inline_attribute e.exp_attributes; 750 specialise = Translattribute.get_specialise_attribute e.exp_attributes; 751 } 752 in 753 let loc = e.exp_loc in 754 Lfunction{kind; params; body; attr; loc} 755 | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p}); 756 exp_type = prim_type } as funct, oargs) 757 when List.length oargs >= p.prim_arity 758 && List.for_all (fun (_, arg) -> arg <> None) oargs -> 759 let args, args' = cut p.prim_arity oargs in 760 let wrap f = 761 if args' = [] 762 then event_after e f 763 else 764 let should_be_tailcall, funct = 765 Translattribute.get_tailcall_attribute funct 766 in 767 let inlined, funct = 768 Translattribute.get_and_remove_inlined_attribute funct 769 in 770 let specialised, funct = 771 Translattribute.get_and_remove_specialised_attribute funct 772 in 773 let e = { e with exp_desc = Texp_apply(funct, oargs) } in 774 event_after e 775 (transl_apply ~should_be_tailcall ~inlined ~specialised 776 f args' e.exp_loc) 777 in 778 let wrap0 f = 779 if args' = [] then f else wrap f in 780 let args = 781 List.map (function _, Some x -> x | _ -> assert false) args in 782 let argl = transl_list args in 783 let public_send = p.prim_name = "%send" 784 || not !Clflags.native_code && p.prim_name = "%sendcache"in 785 if public_send || p.prim_name = "%sendself" then 786 let kind = if public_send then Public else Self in 787 let obj = List.hd argl in 788 wrap (Lsend (kind, List.nth argl 1, obj, [], e.exp_loc)) 789 else if p.prim_name = "%sendcache" then 790 match argl with [obj; meth; cache; pos] -> 791 wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc)) 792 | _ -> assert false 793 else if p.prim_name = "%raise_with_backtrace" then begin 794 let texn1 = List.hd args (* Should not fail by typing *) in 795 let texn2,bt = match argl with 796 | [a;b] -> a,b 797 | _ -> assert false (* idem *) 798 in 799 let vexn = Ident.create "exn" in 800 Llet(Strict, Pgenval, vexn, texn2, 801 event_before e begin 802 Lsequence( 803 wrap (Lprim (Pccall prim_restore_raw_backtrace, 804 [Lvar vexn;bt], 805 e.exp_loc)), 806 wrap0 (Lprim(Praise Raise_reraise, 807 [event_after texn1 (Lvar vexn)], 808 e.exp_loc)) 809 ) 810 end 811 ) 812 end 813 else begin 814 let prim = transl_primitive_application 815 e.exp_loc p e.exp_env prim_type (Some path) args in 816 match (prim, args) with 817 (Praise k, [arg1]) -> 818 let targ = List.hd argl in 819 let k = 820 match k, targ with 821 | Raise_regular, Lvar id 822 when Hashtbl.mem try_ids id -> 823 Raise_reraise 824 | _ -> 825 k 826 in 827 wrap0 (Lprim(Praise k, [event_after arg1 targ], e.exp_loc)) 828 | (Ploc kind, []) -> 829 lam_of_loc kind e.exp_loc 830 | (Ploc kind, [arg1]) -> 831 let lam = lam_of_loc kind arg1.exp_loc in 832 Lprim(Pmakeblock(0, Immutable, None), lam :: argl, e.exp_loc) 833 | (Ploc _, _) -> assert false 834 | (_, _) -> 835 begin match (prim, argl) with 836 | (Plazyforce, [a]) -> 837 wrap (Matching.inline_lazy_force a e.exp_loc) 838 | (Plazyforce, _) -> assert false 839 |_ -> let p = Lprim(prim, argl, e.exp_loc) in 840 if primitive_is_ccall prim then wrap p else wrap0 p 841 end 842 end 843 | Texp_apply(funct, oargs) -> 844 let should_be_tailcall, funct = 845 Translattribute.get_tailcall_attribute funct 846 in 847 let inlined, funct = 848 Translattribute.get_and_remove_inlined_attribute funct 849 in 850 let specialised, funct = 851 Translattribute.get_and_remove_specialised_attribute funct 852 in 853 let e = { e with exp_desc = Texp_apply(funct, oargs) } in 854 event_after e 855 (transl_apply ~should_be_tailcall ~inlined ~specialised 856 (transl_exp funct) oargs e.exp_loc) 857 | Texp_match(arg, pat_expr_list, exn_pat_expr_list, partial) -> 858 transl_match e arg pat_expr_list exn_pat_expr_list partial 859 | Texp_try(body, pat_expr_list) -> 860 let id = Typecore.name_pattern "exn" pat_expr_list in 861 Ltrywith(transl_exp body, id, 862 Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list)) 863 | Texp_tuple el -> 864 let ll, shape = transl_list_with_shape el in 865 begin try 866 Lconst(Const_block(0, List.map extract_constant ll)) 867 with Not_constant -> 868 Lprim(Pmakeblock(0, Immutable, Some shape), ll, e.exp_loc) 869 end 870 | Texp_construct(_, cstr, args) -> 871 let ll, shape = transl_list_with_shape args in 872 if cstr.cstr_inlined <> None then begin match ll with 873 | [x] -> x 874 | _ -> assert false 875 end else begin match cstr.cstr_tag with 876 Cstr_constant n -> 877 Lconst(Const_pointer n) 878 | Cstr_unboxed -> 879 (match ll with [v] -> v | _ -> assert false) 880 | Cstr_block n -> 881 begin try 882 Lconst(Const_block(n, List.map extract_constant ll)) 883 with Not_constant -> 884 Lprim(Pmakeblock(n, Immutable, Some shape), ll, e.exp_loc) 885 end 886 | Cstr_extension(path, is_const) -> 887 if is_const then 888 transl_path e.exp_env path 889 else 890 Lprim(Pmakeblock(0, Immutable, Some (Pgenval :: shape)), 891 transl_path e.exp_env path :: ll, e.exp_loc) 892 end 893 | Texp_extension_constructor (_, path) -> 894 transl_path e.exp_env path 895 | Texp_variant(l, arg) -> 896 let tag = Btype.hash_variant l in 897 begin match arg with 898 None -> Lconst(Const_pointer tag) 899 | Some arg -> 900 let lam = transl_exp arg in 901 try 902 Lconst(Const_block(0, [Const_base(Const_int tag); 903 extract_constant lam])) 904 with Not_constant -> 905 Lprim(Pmakeblock(0, Immutable, None), 906 [Lconst(Const_base(Const_int tag)); lam], e.exp_loc) 907 end 908 | Texp_record {fields; representation; extended_expression} -> 909 transl_record e.exp_loc e.exp_env fields representation 910 extended_expression 911 | Texp_field(arg, _, lbl) -> 912 let targ = transl_exp arg in 913 begin match lbl.lbl_repres with 914 Record_regular | Record_inlined _ -> 915 Lprim (Pfield lbl.lbl_pos, [targ], e.exp_loc) 916 | Record_unboxed _ -> targ 917 | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [targ], e.exp_loc) 918 | Record_extension -> 919 Lprim (Pfield (lbl.lbl_pos + 1), [targ], e.exp_loc) 920 end 921 | Texp_setfield(arg, _, lbl, newval) -> 922 let access = 923 match lbl.lbl_repres with 924 Record_regular 925 | Record_inlined _ -> 926 Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment) 927 | Record_unboxed _ -> assert false 928 | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment) 929 | Record_extension -> 930 Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment) 931 in 932 Lprim(access, [transl_exp arg; transl_exp newval], e.exp_loc) 933 | Texp_array expr_list -> 934 let kind = array_kind e in 935 let ll = transl_list expr_list in 936 begin try 937 (* For native code the decision as to which compilation strategy to 938 use is made later. This enables the Flambda passes to lift certain 939 kinds of array definitions to symbols. *) 940 (* Deactivate constant optimization if array is small enough *) 941 if List.length ll <= use_dup_for_constant_arrays_bigger_than 942 then begin 943 raise Not_constant 944 end; 945 begin match List.map extract_constant ll with 946 | exception Not_constant when kind = Pfloatarray -> 947 (* We cannot currently lift [Pintarray] arrays safely in Flambda 948 because [caml_modify] might be called upon them (e.g. from 949 code operating on polymorphic arrays, or functions such as 950 [caml_array_blit]. 951 To avoid having different Lambda code for 952 bytecode/Closure vs. Flambda, we always generate 953 [Pduparray] here, and deal with it in [Bytegen] (or in 954 the case of Closure, in [Cmmgen], which already has to 955 handle [Pduparray Pmakearray Pfloatarray] in the case 956 where the array turned out to be inconstant). 957 When not [Pfloatarray], the exception propagates to the handler 958 below. *) 959 let imm_array = 960 Lprim (Pmakearray (kind, Immutable), ll, e.exp_loc) 961 in 962 Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc) 963 | cl -> 964 let imm_array = 965 match kind with 966 | Paddrarray | Pintarray -> 967 Lconst(Const_block(0, cl)) 968 | Pfloatarray -> 969 Lconst(Const_float_array(List.map extract_float cl)) 970 | Pgenarray -> 971 raise Not_constant (* can this really happen? *) 972 in 973 Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc) 974 end 975 with Not_constant -> 976 Lprim(Pmakearray (kind, Mutable), ll, e.exp_loc) 977 end 978 | Texp_ifthenelse(cond, ifso, Some ifnot) -> 979 Lifthenelse(transl_exp cond, 980 event_before ifso (transl_exp ifso), 981 event_before ifnot (transl_exp ifnot)) 982 | Texp_ifthenelse(cond, ifso, None) -> 983 Lifthenelse(transl_exp cond, 984 event_before ifso (transl_exp ifso), 985 lambda_unit) 986 | Texp_sequence(expr1, expr2) -> 987 Lsequence(transl_exp expr1, event_before expr2 (transl_exp expr2)) 988 | Texp_while(cond, body) -> 989 Lwhile(transl_exp cond, event_before body (transl_exp body)) 990 | Texp_for(param, _, low, high, dir, body) -> 991 Lfor(param, transl_exp low, transl_exp high, dir, 992 event_before body (transl_exp body)) 993 | Texp_send(_, _, Some exp) -> transl_exp exp 994 | Texp_send(expr, met, None) -> 995 let obj = transl_exp expr in 996 let lam = 997 match met with 998 Tmeth_val id -> Lsend (Self, Lvar id, obj, [], e.exp_loc) 999 | Tmeth_name nm -> 1000 let (tag, cache) = Translobj.meth obj nm in 1001 let kind = if cache = [] then Public else Cached in 1002 Lsend (kind, tag, obj, cache, e.exp_loc) 1003 in 1004 event_after e lam 1005 | Texp_new (cl, {Location.loc=loc}, _) -> 1006 Lapply{ap_should_be_tailcall=false; 1007 ap_loc=loc; 1008 ap_func=Lprim(Pfield 0, [transl_path ~loc e.exp_env cl], loc); 1009 ap_args=[lambda_unit]; 1010 ap_inlined=Default_inline; 1011 ap_specialised=Default_specialise} 1012 | Texp_instvar(path_self, path, _) -> 1013 Lprim(Pfield_computed, 1014 [transl_normal_path path_self; transl_normal_path path], e.exp_loc) 1015 | Texp_setinstvar(path_self, path, _, expr) -> 1016 transl_setinstvar e.exp_loc (transl_normal_path path_self) path expr 1017 | Texp_override(path_self, modifs) -> 1018 let cpy = Ident.create "copy" in 1019 Llet(Strict, Pgenval, cpy, 1020 Lapply{ap_should_be_tailcall=false; 1021 ap_loc=Location.none; 1022 ap_func=Translobj.oo_prim "copy"; 1023 ap_args=[transl_normal_path path_self]; 1024 ap_inlined=Default_inline; 1025 ap_specialised=Default_specialise}, 1026 List.fold_right 1027 (fun (path, _, expr) rem -> 1028 Lsequence(transl_setinstvar Location.none 1029 (Lvar cpy) path expr, rem)) 1030 modifs 1031 (Lvar cpy)) 1032 | Texp_letmodule(id, _, modl, body) -> 1033 Llet(Strict, Pgenval, id, 1034 !transl_module Tcoerce_none None modl, 1035 transl_exp body) 1036 | Texp_letexception(cd, body) -> 1037 Llet(Strict, Pgenval, 1038 cd.ext_id, transl_extension_constructor e.exp_env None cd, 1039 transl_exp body) 1040 | Texp_pack modl -> 1041 !transl_module Tcoerce_none None modl 1042 | Texp_assert {exp_desc=Texp_construct(_, {cstr_name="false"}, _)} -> 1043 assert_failed e 1044 | Texp_assert (cond) -> 1045 if !Clflags.noassert 1046 then lambda_unit 1047 else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e) 1048 | Texp_lazy e -> 1049 (* when e needs no computation (constants, identifiers, ...), we 1050 optimize the translation just as Lazy.lazy_from_val would 1051 do *) 1052 begin match e.exp_desc with 1053 (* a constant expr of type <> float gets compiled as itself *) 1054 | Texp_constant 1055 ( Const_int _ | Const_char _ | Const_string _ 1056 | Const_int32 _ | Const_int64 _ | Const_nativeint _ ) 1057 | Texp_function _ 1058 | Texp_construct (_, {cstr_arity = 0}, _) 1059 -> transl_exp e 1060 | Texp_constant(Const_float _) -> 1061 (* We don't need to wrap with Popaque: this forward 1062 block will never be shortcutted since it points to a float. *) 1063 Lprim(Pmakeblock(Obj.forward_tag, Immutable, None), 1064 [transl_exp e], e.exp_loc) 1065 | Texp_ident _ -> 1066 (* CR-someday mshinwell: Consider adding a new primitive 1067 that expresses the construction of forward_tag blocks. 1068 We need to use [Popaque] here to prevent unsound 1069 optimisation in Flambda, but the concept of a mutable 1070 block doesn't really match what is going on here. This 1071 value may subsequently turn into an immediate... *) 1072 if Typeopt.lazy_val_requires_forward e.exp_env e.exp_type 1073 then 1074 Lprim (Popaque, 1075 [Lprim(Pmakeblock(Obj.forward_tag, Immutable, None), 1076 [transl_exp e], e.exp_loc)], 1077 e.exp_loc) 1078 else transl_exp e 1079 (* other cases compile to a lazy block holding a function *) 1080 | _ -> 1081 let fn = Lfunction {kind = Curried; params = [Ident.create "param"]; 1082 attr = default_function_attribute; 1083 loc = e.exp_loc; 1084 body = transl_exp e} in 1085 Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [fn], e.exp_loc) 1086 end 1087 | Texp_object (cs, meths) -> 1088 let cty = cs.cstr_type in 1089 let cl = Ident.create "class" in 1090 !transl_object cl meths 1091 { cl_desc = Tcl_structure cs; 1092 cl_loc = e.exp_loc; 1093 cl_type = Cty_signature cty; 1094 cl_env = e.exp_env; 1095 cl_attributes = []; 1096 } 1097 | Texp_unreachable -> 1098 raise (Error (e.exp_loc, Unreachable_reached)) 1099 1100and transl_list expr_list = 1101 List.map transl_exp expr_list 1102 1103and transl_list_with_shape expr_list = 1104 let transl_with_shape e = 1105 let shape = Typeopt.value_kind e.exp_env e.exp_type in 1106 transl_exp e, shape 1107 in 1108 List.split (List.map transl_with_shape expr_list) 1109 1110and transl_guard guard rhs = 1111 let expr = event_before rhs (transl_exp rhs) in 1112 match guard with 1113 | None -> expr 1114 | Some cond -> 1115 event_before cond (Lifthenelse(transl_exp cond, expr, staticfail)) 1116 1117and transl_case {c_lhs; c_guard; c_rhs} = 1118 c_lhs, transl_guard c_guard c_rhs 1119 1120and transl_cases cases = 1121 let cases = 1122 List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in 1123 List.map transl_case cases 1124 1125and transl_case_try {c_lhs; c_guard; c_rhs} = 1126 match c_lhs.pat_desc with 1127 | Tpat_var (id, _) 1128 | Tpat_alias (_, id, _) -> 1129 Hashtbl.replace try_ids id (); 1130 Misc.try_finally 1131 (fun () -> c_lhs, transl_guard c_guard c_rhs) 1132 (fun () -> Hashtbl.remove try_ids id) 1133 | _ -> 1134 c_lhs, transl_guard c_guard c_rhs 1135 1136and transl_cases_try cases = 1137 let cases = 1138 List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in 1139 List.map transl_case_try cases 1140 1141and transl_tupled_cases patl_expr_list = 1142 let patl_expr_list = 1143 List.filter (fun (_,_,e) -> e.exp_desc <> Texp_unreachable) 1144 patl_expr_list in 1145 List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr)) 1146 patl_expr_list 1147 1148and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline) 1149 ?(specialised = Default_specialise) lam sargs loc = 1150 let lapply funct args = 1151 match funct with 1152 Lsend(k, lmet, lobj, largs, loc) -> 1153 Lsend(k, lmet, lobj, largs @ args, loc) 1154 | Levent(Lsend(k, lmet, lobj, largs, loc), _) -> 1155 Lsend(k, lmet, lobj, largs @ args, loc) 1156 | Lapply ap -> 1157 Lapply {ap with ap_args = ap.ap_args @ args; ap_loc = loc} 1158 | lexp -> 1159 Lapply {ap_should_be_tailcall=should_be_tailcall; 1160 ap_loc=loc; 1161 ap_func=lexp; 1162 ap_args=args; 1163 ap_inlined=inlined; 1164 ap_specialised=specialised;} 1165 in 1166 let rec build_apply lam args = function 1167 (None, optional) :: l -> 1168 let defs = ref [] in 1169 let protect name lam = 1170 match lam with 1171 Lvar _ | Lconst _ -> lam 1172 | _ -> 1173 let id = Ident.create name in 1174 defs := (id, lam) :: !defs; 1175 Lvar id 1176 in 1177 let args, args' = 1178 if List.for_all (fun (_,opt) -> opt) args then [], args 1179 else args, [] in 1180 let lam = 1181 if args = [] then lam else lapply lam (List.rev_map fst args) in 1182 let handle = protect "func" lam 1183 and l = List.map (fun (arg, opt) -> may_map (protect "arg") arg, opt) l 1184 and id_arg = Ident.create "param" in 1185 let body = 1186 match build_apply handle ((Lvar id_arg, optional)::args') l with 1187 Lfunction{kind = Curried; params = ids; body = lam; attr; loc} -> 1188 Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr; 1189 loc} 1190 | Levent(Lfunction{kind = Curried; params = ids; 1191 body = lam; attr; loc}, _) -> 1192 Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr; 1193 loc} 1194 | lam -> 1195 Lfunction{kind = Curried; params = [id_arg]; body = lam; 1196 attr = default_stub_attribute; loc = loc} 1197 in 1198 List.fold_left 1199 (fun body (id, lam) -> Llet(Strict, Pgenval, id, lam, body)) 1200 body !defs 1201 | (Some arg, optional) :: l -> 1202 build_apply lam ((arg, optional) :: args) l 1203 | [] -> 1204 lapply lam (List.rev_map fst args) 1205 in 1206 (build_apply lam [] (List.map (fun (l, x) -> 1207 may_map transl_exp x, Btype.is_optional l) 1208 sargs) 1209 : Lambda.lambda) 1210 1211and transl_function loc untuplify_fn repr partial param cases = 1212 match cases with 1213 [{c_lhs=pat; c_guard=None; 1214 c_rhs={exp_desc = Texp_function { arg_label = _; param = param'; cases; 1215 partial = partial'; }} as exp}] 1216 when Parmatch.fluid pat -> 1217 let ((_, params), body) = 1218 transl_function exp.exp_loc false repr partial' param' cases in 1219 ((Curried, param :: params), 1220 Matching.for_function loc None (Lvar param) [pat, body] partial) 1221 | {c_lhs={pat_desc = Tpat_tuple pl}} :: _ when untuplify_fn -> 1222 begin try 1223 let size = List.length pl in 1224 let pats_expr_list = 1225 List.map 1226 (fun {c_lhs; c_guard; c_rhs} -> 1227 (Matching.flatten_pattern size c_lhs, c_guard, c_rhs)) 1228 cases in 1229 let params = List.map (fun _ -> Ident.create "param") pl in 1230 ((Tupled, params), 1231 Matching.for_tupled_function loc params 1232 (transl_tupled_cases pats_expr_list) partial) 1233 with Matching.Cannot_flatten -> 1234 ((Curried, [param]), 1235 Matching.for_function loc repr (Lvar param) 1236 (transl_cases cases) partial) 1237 end 1238 | _ -> 1239 ((Curried, [param]), 1240 Matching.for_function loc repr (Lvar param) 1241 (transl_cases cases) partial) 1242 1243and transl_let rec_flag pat_expr_list body = 1244 match rec_flag with 1245 Nonrecursive -> 1246 let rec transl = function 1247 [] -> 1248 body 1249 | {vb_pat=pat; vb_expr=expr; vb_attributes=attr; vb_loc} :: rem -> 1250 let lam = transl_exp expr in 1251 let lam = 1252 Translattribute.add_inline_attribute lam vb_loc attr 1253 in 1254 let lam = 1255 Translattribute.add_specialise_attribute lam vb_loc attr 1256 in 1257 Matching.for_let pat.pat_loc lam pat (transl rem) 1258 in transl pat_expr_list 1259 | Recursive -> 1260 let idlist = 1261 List.map 1262 (fun {vb_pat=pat} -> match pat.pat_desc with 1263 Tpat_var (id,_) -> id 1264 | Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id 1265 | _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat))) 1266 pat_expr_list in 1267 let transl_case {vb_expr=expr; vb_attributes; vb_loc} id = 1268 let lam = transl_exp expr in 1269 let lam = 1270 Translattribute.add_inline_attribute lam vb_loc 1271 vb_attributes 1272 in 1273 let lam = 1274 Translattribute.add_specialise_attribute lam vb_loc 1275 vb_attributes 1276 in 1277 if not (check_recursive_lambda idlist lam) then 1278 raise(Error(expr.exp_loc, Illegal_letrec_expr)); 1279 (id, lam) in 1280 Lletrec(List.map2 transl_case pat_expr_list idlist, body) 1281 1282and transl_setinstvar loc self var expr = 1283 Lprim(Psetfield_computed (maybe_pointer expr, Assignment), 1284 [self; transl_normal_path var; transl_exp expr], loc) 1285 1286and transl_record loc env fields repres opt_init_expr = 1287 let size = Array.length fields in 1288 (* Determine if there are "enough" fields (only relevant if this is a 1289 functional-style record update *) 1290 let no_init = match opt_init_expr with None -> true | _ -> false in 1291 if no_init || size < Config.max_young_wosize 1292 then begin 1293 (* Allocate new record with given fields (and remaining fields 1294 taken from init_expr if any *) 1295 let init_id = Ident.create "init" in 1296 let lv = 1297 Array.mapi 1298 (fun i (_, definition) -> 1299 match definition with 1300 | Kept typ -> 1301 let field_kind = value_kind env typ in 1302 let access = 1303 match repres with 1304 Record_regular | Record_inlined _ -> Pfield i 1305 | Record_unboxed _ -> assert false 1306 | Record_extension -> Pfield (i + 1) 1307 | Record_float -> Pfloatfield i in 1308 Lprim(access, [Lvar init_id], loc), field_kind 1309 | Overridden (_lid, expr) -> 1310 let field_kind = value_kind expr.exp_env expr.exp_type in 1311 transl_exp expr, field_kind) 1312 fields 1313 in 1314 let ll, shape = List.split (Array.to_list lv) in 1315 let mut = 1316 if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields 1317 then Mutable 1318 else Immutable in 1319 let lam = 1320 try 1321 if mut = Mutable then raise Not_constant; 1322 let cl = List.map extract_constant ll in 1323 match repres with 1324 | Record_regular -> Lconst(Const_block(0, cl)) 1325 | Record_inlined tag -> Lconst(Const_block(tag, cl)) 1326 | Record_unboxed _ -> Lconst(match cl with [v] -> v | _ -> assert false) 1327 | Record_float -> 1328 Lconst(Const_float_array(List.map extract_float cl)) 1329 | Record_extension -> 1330 raise Not_constant 1331 with Not_constant -> 1332 match repres with 1333 Record_regular -> 1334 Lprim(Pmakeblock(0, mut, Some shape), ll, loc) 1335 | Record_inlined tag -> 1336 Lprim(Pmakeblock(tag, mut, Some shape), ll, loc) 1337 | Record_unboxed _ -> (match ll with [v] -> v | _ -> assert false) 1338 | Record_float -> 1339 Lprim(Pmakearray (Pfloatarray, mut), ll, loc) 1340 | Record_extension -> 1341 let path = 1342 let (label, _) = fields.(0) in 1343 match label.lbl_res.desc with 1344 | Tconstr(p, _, _) -> p 1345 | _ -> assert false 1346 in 1347 let slot = transl_path env path in 1348 Lprim(Pmakeblock(0, mut, Some (Pgenval :: shape)), slot :: ll, loc) 1349 in 1350 begin match opt_init_expr with 1351 None -> lam 1352 | Some init_expr -> Llet(Strict, Pgenval, init_id, 1353 transl_exp init_expr, lam) 1354 end 1355 end else begin 1356 (* Take a shallow copy of the init record, then mutate the fields 1357 of the copy *) 1358 (* If you change anything here, you will likely have to change 1359 [check_recursive_recordwith] in this file. *) 1360 let copy_id = Ident.create "newrecord" in 1361 let update_field cont (lbl, definition) = 1362 match definition with 1363 | Kept _type -> cont 1364 | Overridden (_lid, expr) -> 1365 let upd = 1366 match repres with 1367 Record_regular 1368 | Record_inlined _ -> 1369 Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment) 1370 | Record_unboxed _ -> assert false 1371 | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment) 1372 | Record_extension -> 1373 Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment) 1374 in 1375 Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr], loc), cont) 1376 in 1377 begin match opt_init_expr with 1378 None -> assert false 1379 | Some init_expr -> 1380 Llet(Strict, Pgenval, copy_id, 1381 Lprim(Pduprecord (repres, size), [transl_exp init_expr], loc), 1382 Array.fold_left update_field (Lvar copy_id) fields) 1383 end 1384 end 1385 1386and transl_match e arg pat_expr_list exn_pat_expr_list partial = 1387 let id = Typecore.name_pattern "exn" exn_pat_expr_list 1388 and cases = transl_cases pat_expr_list 1389 and exn_cases = transl_cases_try exn_pat_expr_list in 1390 let static_catch body val_ids handler = 1391 let static_exception_id = next_negative_raise_count () in 1392 Lstaticcatch 1393 (Ltrywith (Lstaticraise (static_exception_id, body), id, 1394 Matching.for_trywith (Lvar id) exn_cases), 1395 (static_exception_id, val_ids), 1396 handler) 1397 in 1398 match arg, exn_cases with 1399 | {exp_desc = Texp_tuple argl}, [] -> 1400 Matching.for_multiple_match e.exp_loc (transl_list argl) cases partial 1401 | {exp_desc = Texp_tuple argl}, _ :: _ -> 1402 let val_ids = List.map (fun _ -> Typecore.name_pattern "val" []) argl in 1403 let lvars = List.map (fun id -> Lvar id) val_ids in 1404 static_catch (transl_list argl) val_ids 1405 (Matching.for_multiple_match e.exp_loc lvars cases partial) 1406 | arg, [] -> 1407 Matching.for_function e.exp_loc None (transl_exp arg) cases partial 1408 | arg, _ :: _ -> 1409 let val_id = Typecore.name_pattern "val" pat_expr_list in 1410 static_catch [transl_exp arg] [val_id] 1411 (Matching.for_function e.exp_loc None (Lvar val_id) cases partial) 1412 1413 1414(* Wrapper for class compilation *) 1415 1416(* 1417let transl_exp = transl_exp_wrap 1418 1419let transl_let rec_flag pat_expr_list body = 1420 match pat_expr_list with 1421 [] -> body 1422 | (_, expr) :: _ -> 1423 Translobj.oo_wrap expr.exp_env false 1424 (transl_let rec_flag pat_expr_list) body 1425*) 1426 1427(* Error report *) 1428 1429open Format 1430 1431let report_error ppf = function 1432 | Illegal_letrec_pat -> 1433 fprintf ppf 1434 "Only variables are allowed as left-hand side of `let rec'" 1435 | Illegal_letrec_expr -> 1436 fprintf ppf 1437 "This kind of expression is not allowed as right-hand side of `let rec'" 1438 | Free_super_var -> 1439 fprintf ppf 1440 "Ancestor names can only be used to select inherited methods" 1441 | Unknown_builtin_primitive prim_name -> 1442 fprintf ppf "Unknown builtin primitive \"%s\"" prim_name 1443 | Unreachable_reached -> 1444 fprintf ppf "Unreachable expression was reached" 1445 1446let () = 1447 Location.register_error_of_exn 1448 (function 1449 | Error (loc, err) -> 1450 Some (Location.error_of_printer loc report_error err) 1451 | _ -> 1452 None 1453 ) 1454