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 of primitives *)
17
18 open Misc
19 open Asttypes
20 open Primitive
21 open Types
22 open Typedtree
23 open Typeopt
24 open Lambda
25
26 type error =
27 | Unknown_builtin_primitive of string
28 | Wrong_arity_builtin_primitive of string
29
30 exception Error of Location.t * error
31
32 (* Insertion of debugging events *)
33
34 let event_before exp lam = match lam with
35 | Lstaticraise (_,_) -> lam
36 | _ ->
37 if !Clflags.debug && not !Clflags.native_code
38 then Levent(lam, {lev_loc = exp.exp_loc;
39 lev_kind = Lev_before;
40 lev_repr = None;
41 lev_env = exp.exp_env})
42 else lam
43
44 let event_after exp lam =
45 if !Clflags.debug && not !Clflags.native_code
46 then Levent(lam, {lev_loc = exp.exp_loc;
47 lev_kind = Lev_after exp.exp_type;
48 lev_repr = None;
49 lev_env = exp.exp_env})
50 else lam
51
52 type comparison =
53 | Equal
54 | Not_equal
55 | Less_equal
56 | Less_than
57 | Greater_equal
58 | Greater_than
59 | Compare
60
61 type comparison_kind =
62 | Compare_generic
63 | Compare_ints
64 | Compare_floats
65 | Compare_strings
66 | Compare_bytes
67 | Compare_nativeints
68 | Compare_int32s
69 | Compare_int64s
70
71 type loc_kind =
72 | Loc_FILE
73 | Loc_LINE
74 | Loc_MODULE
75 | Loc_LOC
76 | Loc_POS
77
78 type prim =
79 | Primitive of Lambda.primitive * int
80 | External of Primitive.description
81 | Comparison of comparison * comparison_kind
82 | Raise of Lambda.raise_kind
83 | Raise_with_backtrace
84 | Lazy_force
85 | Loc of loc_kind
86 | Send
87 | Send_self
88 | Send_cache
89
90 let used_primitives = Hashtbl.create 7
91 let add_used_primitive loc env path =
92 match path with
93 Some (Path.Pdot _ as path) ->
94 let path = Env.normalize_path_prefix (Some loc) env path in
95 let unit = Path.head path in
96 if Ident.global unit && not (Hashtbl.mem used_primitives path)
97 then Hashtbl.add used_primitives path loc
98 | _ -> ()
99
100 let clear_used_primitives () = Hashtbl.clear used_primitives
101 let get_used_primitives () =
102 Hashtbl.fold (fun path _ acc -> path :: acc) used_primitives []
103
104 let gen_array_kind =
105 if Config.flat_float_array then Pgenarray else Paddrarray
106
107 let prim_sys_argv =
108 Primitive.simple ~name:"caml_sys_argv" ~arity:1 ~alloc:true
109
110 let primitives_table =
111 create_hashtable 57 [
112 "%identity", Primitive (Pidentity, 1);
113 "%bytes_to_string", Primitive (Pbytes_to_string, 1);
114 "%bytes_of_string", Primitive (Pbytes_of_string, 1);
115 "%ignore", Primitive (Pignore, 1);
116 "%revapply", Primitive (Prevapply, 2);
117 "%apply", Primitive (Pdirapply, 2);
118 "%loc_LOC", Loc Loc_LOC;
119 "%loc_FILE", Loc Loc_FILE;
120 "%loc_LINE", Loc Loc_LINE;
121 "%loc_POS", Loc Loc_POS;
122 "%loc_MODULE", Loc Loc_MODULE;
123 "%field0", Primitive ((Pfield 0), 1);
124 "%field1", Primitive ((Pfield 1), 1);
125 "%setfield0", Primitive ((Psetfield(0, Pointer, Assignment)), 2);
126 "%makeblock", Primitive ((Pmakeblock(0, Immutable, None)), 1);
127 "%makemutable", Primitive ((Pmakeblock(0, Mutable, None)), 1);
128 "%raise", Raise Raise_regular;
129 "%reraise", Raise Raise_reraise;
130 "%raise_notrace", Raise Raise_notrace;
131 "%raise_with_backtrace", Raise_with_backtrace;
132 "%sequand", Primitive (Psequand, 2);
133 "%sequor", Primitive (Psequor, 2);
134 "%boolnot", Primitive (Pnot, 1);
135 "%big_endian", Primitive ((Pctconst Big_endian), 1);
136 "%backend_type", Primitive ((Pctconst Backend_type), 1);
137 "%word_size", Primitive ((Pctconst Word_size), 1);
138 "%int_size", Primitive ((Pctconst Int_size), 1);
139 "%max_wosize", Primitive ((Pctconst Max_wosize), 1);
140 "%ostype_unix", Primitive ((Pctconst Ostype_unix), 1);
141 "%ostype_win32", Primitive ((Pctconst Ostype_win32), 1);
142 "%ostype_cygwin", Primitive ((Pctconst Ostype_cygwin), 1);
143 "%negint", Primitive (Pnegint, 1);
144 "%succint", Primitive ((Poffsetint 1), 1);
145 "%predint", Primitive ((Poffsetint(-1)), 1);
146 "%addint", Primitive (Paddint, 2);
147 "%subint", Primitive (Psubint, 2);
148 "%mulint", Primitive (Pmulint, 2);
149 "%divint", Primitive ((Pdivint Safe), 2);
150 "%modint", Primitive ((Pmodint Safe), 2);
151 "%andint", Primitive (Pandint, 2);
152 "%orint", Primitive (Porint, 2);
153 "%xorint", Primitive (Pxorint, 2);
154 "%lslint", Primitive (Plslint, 2);
155 "%lsrint", Primitive (Plsrint, 2);
156 "%asrint", Primitive (Pasrint, 2);
157 "%eq", Primitive ((Pintcomp Ceq), 2);
158 "%noteq", Primitive ((Pintcomp Cne), 2);
159 "%ltint", Primitive ((Pintcomp Clt), 2);
160 "%leint", Primitive ((Pintcomp Cle), 2);
161 "%gtint", Primitive ((Pintcomp Cgt), 2);
162 "%geint", Primitive ((Pintcomp Cge), 2);
163 "%incr", Primitive ((Poffsetref(1)), 1);
164 "%decr", Primitive ((Poffsetref(-1)), 1);
165 "%intoffloat", Primitive (Pintoffloat, 1);
166 "%floatofint", Primitive (Pfloatofint, 1);
167 "%negfloat", Primitive (Pnegfloat, 1);
168 "%absfloat", Primitive (Pabsfloat, 1);
169 "%addfloat", Primitive (Paddfloat, 2);
170 "%subfloat", Primitive (Psubfloat, 2);
171 "%mulfloat", Primitive (Pmulfloat, 2);
172 "%divfloat", Primitive (Pdivfloat, 2);
173 "%eqfloat", Primitive ((Pfloatcomp CFeq), 2);
174 "%noteqfloat", Primitive ((Pfloatcomp CFneq), 2);
175 "%ltfloat", Primitive ((Pfloatcomp CFlt), 2);
176 "%lefloat", Primitive ((Pfloatcomp CFle), 2);
177 "%gtfloat", Primitive ((Pfloatcomp CFgt), 2);
178 "%gefloat", Primitive ((Pfloatcomp CFge), 2);
179 "%string_length", Primitive (Pstringlength, 1);
180 "%string_safe_get", Primitive (Pstringrefs, 2);
181 "%string_safe_set", Primitive (Pbytessets, 3);
182 "%string_unsafe_get", Primitive (Pstringrefu, 2);
183 "%string_unsafe_set", Primitive (Pbytessetu, 3);
184 "%bytes_length", Primitive (Pbyteslength, 1);
185 "%bytes_safe_get", Primitive (Pbytesrefs, 2);
186 "%bytes_safe_set", Primitive (Pbytessets, 3);
187 "%bytes_unsafe_get", Primitive (Pbytesrefu, 2);
188 "%bytes_unsafe_set", Primitive (Pbytessetu, 3);
189 "%array_length", Primitive ((Parraylength gen_array_kind), 1);
190 "%array_safe_get", Primitive ((Parrayrefs gen_array_kind), 2);
191 "%array_safe_set", Primitive ((Parraysets gen_array_kind), 3);
192 "%array_unsafe_get", Primitive ((Parrayrefu gen_array_kind), 2);
193 "%array_unsafe_set", Primitive ((Parraysetu gen_array_kind), 3);
194 "%obj_size", Primitive ((Parraylength gen_array_kind), 1);
195 "%obj_field", Primitive ((Parrayrefu gen_array_kind), 2);
196 "%obj_set_field", Primitive ((Parraysetu gen_array_kind), 3);
197 "%floatarray_length", Primitive ((Parraylength Pfloatarray), 1);
198 "%floatarray_safe_get", Primitive ((Parrayrefs Pfloatarray), 2);
199 "%floatarray_safe_set", Primitive ((Parraysets Pfloatarray), 3);
200 "%floatarray_unsafe_get", Primitive ((Parrayrefu Pfloatarray), 2);
201 "%floatarray_unsafe_set", Primitive ((Parraysetu Pfloatarray), 3);
202 "%obj_is_int", Primitive (Pisint, 1);
203 "%lazy_force", Lazy_force;
204 "%nativeint_of_int", Primitive ((Pbintofint Pnativeint), 1);
205 "%nativeint_to_int", Primitive ((Pintofbint Pnativeint), 1);
206 "%nativeint_neg", Primitive ((Pnegbint Pnativeint), 1);
207 "%nativeint_add", Primitive ((Paddbint Pnativeint), 2);
208 "%nativeint_sub", Primitive ((Psubbint Pnativeint), 2);
209 "%nativeint_mul", Primitive ((Pmulbint Pnativeint), 2);
210 "%nativeint_div",
211 Primitive ((Pdivbint { size = Pnativeint; is_safe = Safe }), 2);
212 "%nativeint_mod",
213 Primitive ((Pmodbint { size = Pnativeint; is_safe = Safe }), 2);
214 "%nativeint_and", Primitive ((Pandbint Pnativeint), 2);
215 "%nativeint_or", Primitive ( (Porbint Pnativeint), 2);
216 "%nativeint_xor", Primitive ((Pxorbint Pnativeint), 2);
217 "%nativeint_lsl", Primitive ((Plslbint Pnativeint), 2);
218 "%nativeint_lsr", Primitive ((Plsrbint Pnativeint), 2);
219 "%nativeint_asr", Primitive ((Pasrbint Pnativeint), 2);
220 "%int32_of_int", Primitive ((Pbintofint Pint32), 1);
221 "%int32_to_int", Primitive ((Pintofbint Pint32), 1);
222 "%int32_neg", Primitive ((Pnegbint Pint32), 1);
223 "%int32_add", Primitive ((Paddbint Pint32), 2);
224 "%int32_sub", Primitive ((Psubbint Pint32), 2);
225 "%int32_mul", Primitive ((Pmulbint Pint32), 2);
226 "%int32_div", Primitive ((Pdivbint { size = Pint32; is_safe = Safe }), 2);
227 "%int32_mod", Primitive ((Pmodbint { size = Pint32; is_safe = Safe }), 2);
228 "%int32_and", Primitive ((Pandbint Pint32), 2);
229 "%int32_or", Primitive ( (Porbint Pint32), 2);
230 "%int32_xor", Primitive ((Pxorbint Pint32), 2);
231 "%int32_lsl", Primitive ((Plslbint Pint32), 2);
232 "%int32_lsr", Primitive ((Plsrbint Pint32), 2);
233 "%int32_asr", Primitive ((Pasrbint Pint32), 2);
234 "%int64_of_int", Primitive ((Pbintofint Pint64), 1);
235 "%int64_to_int", Primitive ((Pintofbint Pint64), 1);
236 "%int64_neg", Primitive ((Pnegbint Pint64), 1);
237 "%int64_add", Primitive ((Paddbint Pint64), 2);
238 "%int64_sub", Primitive ((Psubbint Pint64), 2);
239 "%int64_mul", Primitive ((Pmulbint Pint64), 2);
240 "%int64_div", Primitive ((Pdivbint { size = Pint64; is_safe = Safe }), 2);
241 "%int64_mod", Primitive ((Pmodbint { size = Pint64; is_safe = Safe }), 2);
242 "%int64_and", Primitive ((Pandbint Pint64), 2);
243 "%int64_or", Primitive ( (Porbint Pint64), 2);
244 "%int64_xor", Primitive ((Pxorbint Pint64), 2);
245 "%int64_lsl", Primitive ((Plslbint Pint64), 2);
246 "%int64_lsr", Primitive ((Plsrbint Pint64), 2);
247 "%int64_asr", Primitive ((Pasrbint Pint64), 2);
248 "%nativeint_of_int32", Primitive ((Pcvtbint(Pint32, Pnativeint)), 1);
249 "%nativeint_to_int32", Primitive ((Pcvtbint(Pnativeint, Pint32)), 1);
250 "%int64_of_int32", Primitive ((Pcvtbint(Pint32, Pint64)), 1);
251 "%int64_to_int32", Primitive ((Pcvtbint(Pint64, Pint32)), 1);
252 "%int64_of_nativeint", Primitive ((Pcvtbint(Pnativeint, Pint64)), 1);
253 "%int64_to_nativeint", Primitive ((Pcvtbint(Pint64, Pnativeint)), 1);
254 "%caml_ba_ref_1",
255 Primitive
256 ((Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)),
257 2);
258 "%caml_ba_ref_2",
259 Primitive
260 ((Pbigarrayref(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout)),
261 3);
262 "%caml_ba_ref_3",
263 Primitive
264 ((Pbigarrayref(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout)),
265 4);
266 "%caml_ba_set_1",
267 Primitive
268 ((Pbigarrayset(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)),
269 3);
270 "%caml_ba_set_2",
271 Primitive
272 ((Pbigarrayset(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout)),
273 4);
274 "%caml_ba_set_3",
275 Primitive
276 ((Pbigarrayset(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout)),
277 5);
278 "%caml_ba_unsafe_ref_1",
279 Primitive
280 ((Pbigarrayref(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout)),
281 2);
282 "%caml_ba_unsafe_ref_2",
283 Primitive
284 ((Pbigarrayref(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout)),
285 3);
286 "%caml_ba_unsafe_ref_3",
287 Primitive
288 ((Pbigarrayref(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)),
289 4);
290 "%caml_ba_unsafe_set_1",
291 Primitive
292 ((Pbigarrayset(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout)),
293 3);
294 "%caml_ba_unsafe_set_2",
295 Primitive
296 ((Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout)),
297 4);
298 "%caml_ba_unsafe_set_3",
299 Primitive
300 ((Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)),
301 5);
302 "%caml_ba_dim_1", Primitive ((Pbigarraydim(1)), 1);
303 "%caml_ba_dim_2", Primitive ((Pbigarraydim(2)), 1);
304 "%caml_ba_dim_3", Primitive ((Pbigarraydim(3)), 1);
305 "%caml_string_get16", Primitive ((Pstring_load_16(false)), 2);
306 "%caml_string_get16u", Primitive ((Pstring_load_16(true)), 2);
307 "%caml_string_get32", Primitive ((Pstring_load_32(false)), 2);
308 "%caml_string_get32u", Primitive ((Pstring_load_32(true)), 2);
309 "%caml_string_get64", Primitive ((Pstring_load_64(false)), 2);
310 "%caml_string_get64u", Primitive ((Pstring_load_64(true)), 2);
311 "%caml_string_set16", Primitive ((Pbytes_set_16(false)), 3);
312 "%caml_string_set16u", Primitive ((Pbytes_set_16(true)), 3);
313 "%caml_string_set32", Primitive ((Pbytes_set_32(false)), 3);
314 "%caml_string_set32u", Primitive ((Pbytes_set_32(true)), 3);
315 "%caml_string_set64", Primitive ((Pbytes_set_64(false)), 3);
316 "%caml_string_set64u", Primitive ((Pbytes_set_64(true)), 3);
317 "%caml_bytes_get16", Primitive ((Pbytes_load_16(false)), 2);
318 "%caml_bytes_get16u", Primitive ((Pbytes_load_16(true)), 2);
319 "%caml_bytes_get32", Primitive ((Pbytes_load_32(false)), 2);
320 "%caml_bytes_get32u", Primitive ((Pbytes_load_32(true)), 2);
321 "%caml_bytes_get64", Primitive ((Pbytes_load_64(false)), 2);
322 "%caml_bytes_get64u", Primitive ((Pbytes_load_64(true)), 2);
323 "%caml_bytes_set16", Primitive ((Pbytes_set_16(false)), 3);
324 "%caml_bytes_set16u", Primitive ((Pbytes_set_16(true)), 3);
325 "%caml_bytes_set32", Primitive ((Pbytes_set_32(false)), 3);
326 "%caml_bytes_set32u", Primitive ((Pbytes_set_32(true)), 3);
327 "%caml_bytes_set64", Primitive ((Pbytes_set_64(false)), 3);
328 "%caml_bytes_set64u", Primitive ((Pbytes_set_64(true)), 3);
329 "%caml_bigstring_get16", Primitive ((Pbigstring_load_16(false)), 2);
330 "%caml_bigstring_get16u", Primitive ((Pbigstring_load_16(true)), 2);
331 "%caml_bigstring_get32", Primitive ((Pbigstring_load_32(false)), 2);
332 "%caml_bigstring_get32u", Primitive ((Pbigstring_load_32(true)), 2);
333 "%caml_bigstring_get64", Primitive ((Pbigstring_load_64(false)), 2);
334 "%caml_bigstring_get64u", Primitive ((Pbigstring_load_64(true)), 2);
335 "%caml_bigstring_set16", Primitive ((Pbigstring_set_16(false)), 3);
336 "%caml_bigstring_set16u", Primitive ((Pbigstring_set_16(true)), 3);
337 "%caml_bigstring_set32", Primitive ((Pbigstring_set_32(false)), 3);
338 "%caml_bigstring_set32u", Primitive ((Pbigstring_set_32(true)), 3);
339 "%caml_bigstring_set64", Primitive ((Pbigstring_set_64(false)), 3);
340 "%caml_bigstring_set64u", Primitive ((Pbigstring_set_64(true)), 3);
341 "%bswap16", Primitive (Pbswap16, 1);
342 "%bswap_int32", Primitive ((Pbbswap(Pint32)), 1);
343 "%bswap_int64", Primitive ((Pbbswap(Pint64)), 1);
344 "%bswap_native", Primitive ((Pbbswap(Pnativeint)), 1);
345 "%int_as_pointer", Primitive (Pint_as_pointer, 1);
346 "%opaque", Primitive (Popaque, 1);
347 "%sys_argv", External prim_sys_argv;
348 "%send", Send;
349 "%sendself", Send_self;
350 "%sendcache", Send_cache;
351 "%equal", Comparison(Equal, Compare_generic);
352 "%notequal", Comparison(Not_equal, Compare_generic);
353 "%lessequal", Comparison(Less_equal, Compare_generic);
354 "%lessthan", Comparison(Less_than, Compare_generic);
355 "%greaterequal", Comparison(Greater_equal, Compare_generic);
356 "%greaterthan", Comparison(Greater_than, Compare_generic);
357 "%compare", Comparison(Compare, Compare_generic);
358 ]
359
360
361 let lookup_primitive loc p =
362 match Hashtbl.find primitives_table p.prim_name with
363 | prim -> prim
364 | exception Not_found ->
365 if String.length p.prim_name > 0 && p.prim_name.[0] = '%' then
366 raise(Error(loc, Unknown_builtin_primitive p.prim_name));
367 External p
368
369 let lookup_primitive_and_mark_used loc p env path =
370 match lookup_primitive loc p with
371 | External _ as e -> add_used_primitive loc env path; e
372 | x -> x
373
374 let simplify_constant_constructor = function
375 | Equal -> true
376 | Not_equal -> true
377 | Less_equal -> false
378 | Less_than -> false
379 | Greater_equal -> false
380 | Greater_than -> false
381 | Compare -> false
382
383 (* The following function computes the greatest lower bound in the
384 semilattice of array kinds:
385 gen
386 / \
387 addr float
388 |
389 int
390 Note that the GLB is not guaranteed to exist, in which case we return
391 our first argument instead of raising a fatal error because, although
392 it cannot happen in a well-typed program, (ab)use of Obj.magic can
393 probably trigger it.
394 *)
395 let glb_array_type t1 t2 =
396 match t1, t2 with
397 | Pfloatarray, (Paddrarray | Pintarray)
398 | (Paddrarray | Pintarray), Pfloatarray -> t1
399
400 | Pgenarray, x | x, Pgenarray -> x
401 | Paddrarray, x | x, Paddrarray -> x
402 | Pintarray, Pintarray -> Pintarray
403 | Pfloatarray, Pfloatarray -> Pfloatarray
404
405 (* Specialize a primitive from available type information. *)
406
407 let specialize_primitive env ty ~has_constant_constructor prim =
408 let param_tys =
409 match is_function_type env ty with
410 | None -> []
411 | Some (p1, rhs) ->
412 match is_function_type env rhs with
413 | None -> [p1]
414 | Some (p2, _) -> [p1;p2]
415 in
416 match prim, param_tys with
417 | Primitive (Psetfield(n, Pointer, init), arity), [_; p2] -> begin
418 match maybe_pointer_type env p2 with
419 | Pointer -> None
420 | Immediate -> Some (Primitive (Psetfield(n, Immediate, init), arity))
421 end
422 | Primitive (Parraylength t, arity), [p] -> begin
423 let array_type = glb_array_type t (array_type_kind env p) in
424 if t = array_type then None
425 else Some (Primitive (Parraylength array_type, arity))
426 end
427 | Primitive (Parrayrefu t, arity), p1 :: _ -> begin
428 let array_type = glb_array_type t (array_type_kind env p1) in
429 if t = array_type then None
430 else Some (Primitive (Parrayrefu array_type, arity))
431 end
432 | Primitive (Parraysetu t, arity), p1 :: _ -> begin
433 let array_type = glb_array_type t (array_type_kind env p1) in
434 if t = array_type then None
435 else Some (Primitive (Parraysetu array_type, arity))
436 end
437 | Primitive (Parrayrefs t, arity), p1 :: _ -> begin
438 let array_type = glb_array_type t (array_type_kind env p1) in
439 if t = array_type then None
440 else Some (Primitive (Parrayrefs array_type, arity))
441 end
442 | Primitive (Parraysets t, arity), p1 :: _ -> begin
443 let array_type = glb_array_type t (array_type_kind env p1) in
444 if t = array_type then None
445 else Some (Primitive (Parraysets array_type, arity))
446 end
447 | Primitive (Pbigarrayref(unsafe, n, Pbigarray_unknown,
448 Pbigarray_unknown_layout), arity), p1 :: _ -> begin
449 let (k, l) = bigarray_type_kind_and_layout env p1 in
450 match k, l with
451 | Pbigarray_unknown, Pbigarray_unknown_layout -> None
452 | _, _ -> Some (Primitive (Pbigarrayref(unsafe, n, k, l), arity))
453 end
454 | Primitive (Pbigarrayset(unsafe, n, Pbigarray_unknown,
455 Pbigarray_unknown_layout), arity), p1 :: _ -> begin
456 let (k, l) = bigarray_type_kind_and_layout env p1 in
457 match k, l with
458 | Pbigarray_unknown, Pbigarray_unknown_layout -> None
459 | _, _ -> Some (Primitive (Pbigarrayset(unsafe, n, k, l), arity))
460 end
461 | Primitive (Pmakeblock(tag, mut, None), arity), fields -> begin
462 let shape = List.map (Typeopt.value_kind env) fields in
463 let useful = List.exists (fun knd -> knd <> Pgenval) shape in
464 if useful then Some (Primitive (Pmakeblock(tag, mut, Some shape), arity))
465 else None
466 end
467 | Comparison(comp, Compare_generic), p1 :: _ ->
468 if (has_constant_constructor
469 && simplify_constant_constructor comp) then begin
470 Some (Comparison(comp, Compare_ints))
471 end else if (is_base_type env p1 Predef.path_int
472 || is_base_type env p1 Predef.path_char
473 || (maybe_pointer_type env p1 = Immediate)) then begin
474 Some (Comparison(comp, Compare_ints))
475 end else if is_base_type env p1 Predef.path_float then begin
476 Some (Comparison(comp, Compare_floats))
477 end else if is_base_type env p1 Predef.path_string then begin
478 Some (Comparison(comp, Compare_strings))
479 end else if is_base_type env p1 Predef.path_bytes then begin
480 Some (Comparison(comp, Compare_bytes))
481 end else if is_base_type env p1 Predef.path_nativeint then begin
482 Some (Comparison(comp, Compare_nativeints))
483 end else if is_base_type env p1 Predef.path_int32 then begin
484 Some (Comparison(comp, Compare_int32s))
485 end else if is_base_type env p1 Predef.path_int64 then begin
486 Some (Comparison(comp, Compare_int64s))
487 end else begin
488 None
489 end
490 | _ -> None
491
492 let unboxed_compare name native_repr =
493 Primitive.make ~name ~alloc:false ~native_name:(name^"_unboxed")
494 ~native_repr_args:[native_repr;native_repr] ~native_repr_res:Untagged_int
495
496 let caml_equal =
497 Primitive.simple ~name:"caml_equal" ~arity:2 ~alloc:true
498 let caml_string_equal =
499 Primitive.simple ~name:"caml_string_equal" ~arity:2 ~alloc:false
500 let caml_bytes_equal =
501 Primitive.simple ~name:"caml_bytes_equal" ~arity:2 ~alloc:false
502 let caml_notequal =
503 Primitive.simple ~name:"caml_notequal" ~arity:2 ~alloc:true
504 let caml_string_notequal =
505 Primitive.simple ~name:"caml_string_notequal" ~arity:2 ~alloc:false
506 let caml_bytes_notequal =
507 Primitive.simple ~name:"caml_bytes_notequal" ~arity:2 ~alloc:false
508 let caml_lessequal =
509 Primitive.simple ~name:"caml_lessequal" ~arity:2 ~alloc:true
510 let caml_string_lessequal =
511 Primitive.simple ~name:"caml_string_lessequal" ~arity:2 ~alloc:false
512 let caml_bytes_lessequal =
513 Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2 ~alloc:false
514 let caml_lessthan =
515 Primitive.simple ~name:"caml_lessthan" ~arity:2 ~alloc:true
516 let caml_string_lessthan =
517 Primitive.simple ~name:"caml_string_lessthan" ~arity:2 ~alloc:false
518 let caml_bytes_lessthan =
519 Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2 ~alloc:false
520 let caml_greaterequal =
521 Primitive.simple ~name:"caml_greaterequal" ~arity:2 ~alloc:true
522 let caml_string_greaterequal =
523 Primitive.simple ~name:"caml_string_greaterequal" ~arity:2 ~alloc:false
524 let caml_bytes_greaterequal =
525 Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2 ~alloc:false
526 let caml_greaterthan =
527 Primitive.simple ~name:"caml_greaterthan" ~arity:2 ~alloc:true
528 let caml_string_greaterthan =
529 Primitive.simple ~name:"caml_string_greaterthan" ~arity:2 ~alloc: false
530 let caml_bytes_greaterthan =
531 Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2 ~alloc: false
532 let caml_compare =
533 Primitive.simple ~name:"caml_compare" ~arity:2 ~alloc:true
534 let caml_int_compare =
535 (* Not unboxed since the comparison is done directly on tagged int *)
536 Primitive.simple ~name:"caml_int_compare" ~arity:2 ~alloc:false
537 let caml_float_compare =
538 unboxed_compare "caml_float_compare" Unboxed_float
539 let caml_string_compare =
540 Primitive.simple ~name:"caml_string_compare" ~arity:2 ~alloc:false
541 let caml_bytes_compare =
542 Primitive.simple ~name:"caml_bytes_compare" ~arity:2 ~alloc:false
543 let caml_nativeint_compare =
544 unboxed_compare "caml_nativeint_compare" (Unboxed_integer Pnativeint)
545 let caml_int32_compare =
546 unboxed_compare "caml_int32_compare" (Unboxed_integer Pint32)
547 let caml_int64_compare =
548 unboxed_compare "caml_int64_compare" (Unboxed_integer Pint64)
549
550 let comparison_primitive comparison comparison_kind =
551 match comparison, comparison_kind with
552 | Equal, Compare_generic -> Pccall caml_equal
553 | Equal, Compare_ints -> Pintcomp Ceq
554 | Equal, Compare_floats -> Pfloatcomp CFeq
555 | Equal, Compare_strings -> Pccall caml_string_equal
556 | Equal, Compare_bytes -> Pccall caml_bytes_equal
557 | Equal, Compare_nativeints -> Pbintcomp(Pnativeint, Ceq)
558 | Equal, Compare_int32s -> Pbintcomp(Pint32, Ceq)
559 | Equal, Compare_int64s -> Pbintcomp(Pint64, Ceq)
560 | Not_equal, Compare_generic -> Pccall caml_notequal
561 | Not_equal, Compare_ints -> Pintcomp Cne
562 | Not_equal, Compare_floats -> Pfloatcomp CFneq
563 | Not_equal, Compare_strings -> Pccall caml_string_notequal
564 | Not_equal, Compare_bytes -> Pccall caml_bytes_notequal
565 | Not_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cne)
566 | Not_equal, Compare_int32s -> Pbintcomp(Pint32, Cne)
567 | Not_equal, Compare_int64s -> Pbintcomp(Pint64, Cne)
568 | Less_equal, Compare_generic -> Pccall caml_lessequal
569 | Less_equal, Compare_ints -> Pintcomp Cle
570 | Less_equal, Compare_floats -> Pfloatcomp CFle
571 | Less_equal, Compare_strings -> Pccall caml_string_lessequal
572 | Less_equal, Compare_bytes -> Pccall caml_bytes_lessequal
573 | Less_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cle)
574 | Less_equal, Compare_int32s -> Pbintcomp(Pint32, Cle)
575 | Less_equal, Compare_int64s -> Pbintcomp(Pint64, Cle)
576 | Less_than, Compare_generic -> Pccall caml_lessthan
577 | Less_than, Compare_ints -> Pintcomp Clt
578 | Less_than, Compare_floats -> Pfloatcomp CFlt
579 | Less_than, Compare_strings -> Pccall caml_string_lessthan
580 | Less_than, Compare_bytes -> Pccall caml_bytes_lessthan
581 | Less_than, Compare_nativeints -> Pbintcomp(Pnativeint, Clt)
582 | Less_than, Compare_int32s -> Pbintcomp(Pint32, Clt)
583 | Less_than, Compare_int64s -> Pbintcomp(Pint64, Clt)
584 | Greater_equal, Compare_generic -> Pccall caml_greaterequal
585 | Greater_equal, Compare_ints -> Pintcomp Cge
586 | Greater_equal, Compare_floats -> Pfloatcomp CFge
587 | Greater_equal, Compare_strings -> Pccall caml_string_greaterequal
588 | Greater_equal, Compare_bytes -> Pccall caml_bytes_greaterequal
589 | Greater_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cge)
590 | Greater_equal, Compare_int32s -> Pbintcomp(Pint32, Cge)
591 | Greater_equal, Compare_int64s -> Pbintcomp(Pint64, Cge)
592 | Greater_than, Compare_generic -> Pccall caml_greaterthan
593 | Greater_than, Compare_ints -> Pintcomp Cgt
594 | Greater_than, Compare_floats -> Pfloatcomp CFgt
595 | Greater_than, Compare_strings -> Pccall caml_string_greaterthan
596 | Greater_than, Compare_bytes -> Pccall caml_bytes_greaterthan
597 | Greater_than, Compare_nativeints -> Pbintcomp(Pnativeint, Cgt)
598 | Greater_than, Compare_int32s -> Pbintcomp(Pint32, Cgt)
599 | Greater_than, Compare_int64s -> Pbintcomp(Pint64, Cgt)
600 | Compare, Compare_generic -> Pccall caml_compare
601 | Compare, Compare_ints -> Pccall caml_int_compare
602 | Compare, Compare_floats -> Pccall caml_float_compare
603 | Compare, Compare_strings -> Pccall caml_string_compare
604 | Compare, Compare_bytes -> Pccall caml_bytes_compare
605 | Compare, Compare_nativeints -> Pccall caml_nativeint_compare
606 | Compare, Compare_int32s -> Pccall caml_int32_compare
607 | Compare, Compare_int64s -> Pccall caml_int64_compare
608
609 let lambda_of_loc kind loc =
610 let loc_start = loc.Location.loc_start in
611 let (file, lnum, cnum) = Location.get_pos_info loc_start in
612 let file =
613 if Filename.is_relative file then
614 file
615 else
616 Location.rewrite_absolute_path file in
617 let enum = loc.Location.loc_end.Lexing.pos_cnum -
618 loc_start.Lexing.pos_cnum + cnum in
619 match kind with
620 | Loc_POS ->
621 Lconst (Const_block (0, [
622 Const_immstring file;
623 Const_base (Const_int lnum);
624 Const_base (Const_int cnum);
625 Const_base (Const_int enum);
626 ]))
627 | Loc_FILE -> Lconst (Const_immstring file)
628 | Loc_MODULE ->
629 let filename = Filename.basename file in
630 let name = Env.get_unit_name () in
631 let module_name = if name = "" then "//"^filename^"//" else name in
632 Lconst (Const_immstring module_name)
633 | Loc_LOC ->
634 let loc = Printf.sprintf "File %S, line %d, characters %d-%d"
635 file lnum cnum enum in
636 Lconst (Const_immstring loc)
637 | Loc_LINE -> Lconst (Const_base (Const_int lnum))
638
639 let caml_restore_raw_backtrace =
640 Primitive.simple ~name:"caml_restore_raw_backtrace" ~arity:2 ~alloc:false
641
642 let try_ids = Hashtbl.create 8
643
644 let add_exception_ident id =
645 Hashtbl.replace try_ids id ()
646
647 let remove_exception_ident id =
648 Hashtbl.remove try_ids id
649
650 let lambda_of_prim prim_name prim loc args arg_exps =
651 match prim, args with
652 | Primitive (prim, arity), args when arity = List.length args ->
653 Lprim(prim, args, loc)
654 | External prim, args when prim = prim_sys_argv ->
655 Lprim(Pccall prim, Lconst (Const_pointer 0) :: args, loc)
656 | External prim, args ->
657 Lprim(Pccall prim, args, loc)
658 | Comparison(comp, knd), ([_;_] as args) ->
659 let prim = comparison_primitive comp knd in
660 Lprim(prim, args, loc)
661 | Raise kind, [arg] ->
662 let kind =
663 match kind, arg with
664 | Raise_regular, Lvar argv when Hashtbl.mem try_ids argv ->
665 Raise_reraise
666 | _, _ ->
667 kind
668 in
669 let arg =
670 match arg_exps with
671 | None -> arg
672 | Some [arg_exp] -> event_after arg_exp arg
673 | Some _ -> assert false
674 in
675 Lprim(Praise kind, [arg], loc)
676 | Raise_with_backtrace, [exn; bt] ->
677 let vexn = Ident.create_local "exn" in
678 let raise_arg =
679 match arg_exps with
680 | None -> Lvar vexn
681 | Some [exn_exp; _] -> event_after exn_exp (Lvar vexn)
682 | Some _ -> assert false
683 in
684 Llet(Strict, Pgenval, vexn, exn,
685 Lsequence(Lprim(Pccall caml_restore_raw_backtrace,
686 [Lvar vexn; bt],
687 loc),
688 Lprim(Praise Raise_reraise, [raise_arg], loc)))
689 | Lazy_force, [arg] ->
690 Matching.inline_lazy_force arg Location.none
691 | Loc kind, [] ->
692 lambda_of_loc kind loc
693 | Loc kind, [arg] ->
694 let lam = lambda_of_loc kind loc in
695 Lprim(Pmakeblock(0, Immutable, None), [lam; arg], loc)
696 | Send, [obj; meth] ->
697 Lsend(Public, meth, obj, [], loc)
698 | Send_self, [obj; meth] ->
699 Lsend(Self, meth, obj, [], loc)
700 | Send_cache, [obj; meth; cache; pos] ->
701 Lsend(Cached, meth, obj, [cache; pos], loc)
702 | (Raise _ | Raise_with_backtrace
703 | Lazy_force | Loc _ | Primitive _ | Comparison _
704 | Send | Send_self | Send_cache), _ ->
705 raise(Error(loc, Wrong_arity_builtin_primitive prim_name))
706
707 let check_primitive_arity loc p =
708 let prim = lookup_primitive loc p in
709 let ok =
710 match prim with
711 | Primitive (_,arity) -> arity = p.prim_arity
712 | External _ -> true
713 | Comparison _ -> p.prim_arity = 2
714 | Raise _ -> p.prim_arity = 1
715 | Raise_with_backtrace -> p.prim_arity = 2
716 | Lazy_force -> p.prim_arity = 1
717 | Loc _ -> p.prim_arity = 1 || p.prim_arity = 0
718 | Send | Send_self -> p.prim_arity = 2
719 | Send_cache -> p.prim_arity = 4
720 in
721 if not ok then raise(Error(loc, Wrong_arity_builtin_primitive p.prim_name))
722
723 (* Eta-expand a primitive *)
724
725 let transl_primitive loc p env ty path =
726 let prim = lookup_primitive_and_mark_used loc p env path in
727 let has_constant_constructor = false in
728 let prim =
729 match specialize_primitive env ty ~has_constant_constructor prim with
730 | None -> prim
731 | Some prim -> prim
732 in
733 let rec make_params n =
734 if n <= 0 then []
735 else (Ident.create_local "prim", Pgenval) :: make_params (n-1)
736 in
737 let params = make_params p.prim_arity in
738 let args = List.map (fun (id, _) -> Lvar id) params in
739 let body = lambda_of_prim p.prim_name prim loc args None in
740 match params with
741 | [] -> body
742 | _ ->
743 Lfunction{ kind = Curried;
744 params;
745 return = Pgenval;
746 attr = default_stub_attribute;
747 loc = loc;
748 body = body; }
749
750 (* Determine if a primitive is a Pccall or will be turned later into
751 a C function call that may raise an exception *)
752 let primitive_is_ccall = function
753 | Pccall _ | Pstringrefs | Pbytesrefs | Pbytessets | Parrayrefs _ |
754 Parraysets _ | Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply |
755 Prevapply -> true
756 | _ -> false
757
758 (* Determine if a primitive should be surrounded by an "after" debug event *)
759 let primitive_needs_event_after = function
760 | Primitive (prim,_) -> primitive_is_ccall prim
761 | External _ -> true
762 | Comparison(comp, knd) ->
763 primitive_is_ccall (comparison_primitive comp knd)
764 | Lazy_force | Send | Send_self | Send_cache -> true
765 | Raise _ | Raise_with_backtrace | Loc _ -> false
766
767 let transl_primitive_application loc p env ty path exp args arg_exps =
768 let prim = lookup_primitive_and_mark_used loc p env (Some path) in
769 let has_constant_constructor =
770 match arg_exps with
771 | [_; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}]
772 | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}; _]
773 | [_; {exp_desc = Texp_variant(_, None)}]
774 | [{exp_desc = Texp_variant(_, None)}; _] -> true
775 | _ -> false
776 in
777 let prim =
778 match specialize_primitive env ty ~has_constant_constructor prim with
779 | None -> prim
780 | Some prim -> prim
781 in
782 let lam = lambda_of_prim p.prim_name prim loc args (Some arg_exps) in
783 let lam =
784 if primitive_needs_event_after prim then begin
785 match exp with
786 | None -> lam
787 | Some exp -> event_after exp lam
788 end else begin
789 lam
790 end
791 in
792 lam
793
794 (* Error report *)
795
796 open Format
797
798 let report_error ppf = function
799 | Unknown_builtin_primitive prim_name ->
800 fprintf ppf "Unknown builtin primitive \"%s\"" prim_name
801 | Wrong_arity_builtin_primitive prim_name ->
802 fprintf ppf "Wrong arity for builtin primitive \"%s\"" prim_name
803
804 let () =
805 Location.register_error_of_exn
806 (function
807 | Error (loc, err) ->
808 Some (Location.error_of_printer ~loc report_error err)
809 | _ ->
810 None
811 )
812