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 [@@@ocaml.warning "+a-4-9-40-41-42-44-45"]
17
18 module V = Backend_var
19 module VP = Backend_var.With_provenance
20 open Cmm
21 open Arch
22
23 (* Local binding of complex expressions *)
24
25 let bind name arg fn =
26 match arg with
27 Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _
28 | Cconst_pointer _ | Cconst_natpointer _
29 | Cblockheader _ -> fn arg
30 | _ -> let id = V.create_local name in Clet(VP.create id, arg, fn (Cvar id))
31
32 let bind_load name arg fn =
33 match arg with
34 | Cop(Cload _, [Cvar _], _) -> fn arg
35 | _ -> bind name arg fn
36
37 let bind_nonvar name arg fn =
38 match arg with
39 Cconst_int _ | Cconst_natint _ | Cconst_symbol _
40 | Cconst_pointer _ | Cconst_natpointer _
41 | Cblockheader _ -> fn arg
42 | _ -> let id = V.create_local name in Clet(VP.create id, arg, fn (Cvar id))
43
44 let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8
45 (* cf. runtime/caml/gc.h *)
46
47 (* Block headers. Meaning of the tag field: see stdlib/obj.ml *)
48
49 let floatarray_tag dbg = Cconst_int (Obj.double_array_tag, dbg)
50
51 let block_header tag sz =
52 Nativeint.add (Nativeint.shift_left (Nativeint.of_int sz) 10)
53 (Nativeint.of_int tag)
54 (* Static data corresponding to "value"s must be marked black in case we are
55 in no-naked-pointers mode. See [caml_darken] and the code below that emits
56 structured constants and static module definitions. *)
57 let black_block_header tag sz = Nativeint.logor (block_header tag sz) caml_black
58 let white_closure_header sz = block_header Obj.closure_tag sz
59 let black_closure_header sz = black_block_header Obj.closure_tag sz
60 let infix_header ofs = block_header Obj.infix_tag ofs
61 let float_header = block_header Obj.double_tag (size_float / size_addr)
62 let floatarray_header len =
63 (* Zero-sized float arrays have tag zero for consistency with
64 [caml_alloc_float_array]. *)
65 assert (len >= 0);
66 if len = 0 then block_header 0 0
67 else block_header Obj.double_array_tag (len * size_float / size_addr)
68 let string_header len =
69 block_header Obj.string_tag ((len + size_addr) / size_addr)
70 let boxedint32_header = block_header Obj.custom_tag 2
71 let boxedint64_header = block_header Obj.custom_tag (1 + 8 / size_addr)
72 let boxedintnat_header = block_header Obj.custom_tag 2
73 let caml_nativeint_ops = "caml_nativeint_ops"
74 let caml_int32_ops = "caml_int32_ops"
75 let caml_int64_ops = "caml_int64_ops"
76
77
78 let alloc_float_header dbg = Cblockheader (float_header, dbg)
79 let alloc_floatarray_header len dbg = Cblockheader (floatarray_header len, dbg)
80 let alloc_closure_header sz dbg = Cblockheader (white_closure_header sz, dbg)
81 let alloc_infix_header ofs dbg = Cblockheader (infix_header ofs, dbg)
82 let alloc_boxedint32_header dbg = Cblockheader (boxedint32_header, dbg)
83 let alloc_boxedint64_header dbg = Cblockheader (boxedint64_header, dbg)
84 let alloc_boxedintnat_header dbg = Cblockheader (boxedintnat_header, dbg)
85
86 (* Integers *)
87
88 let max_repr_int = max_int asr 1
89 let min_repr_int = min_int asr 1
90
91 let int_const dbg n =
92 if n <= max_repr_int && n >= min_repr_int
93 then Cconst_int((n lsl 1) + 1, dbg)
94 else Cconst_natint
95 (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n, dbg)
96
97 let natint_const_untagged dbg n =
98 if n > Nativeint.of_int max_int
99 || n < Nativeint.of_int min_int
100 then Cconst_natint (n,dbg)
101 else Cconst_int (Nativeint.to_int n, dbg)
102
103 let cint_const n =
104 Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n)
105
106 let targetint_const n =
107 Targetint.add (Targetint.shift_left (Targetint.of_int n) 1)
108 Targetint.one
109
110 let add_no_overflow n x c dbg =
111 let d = n + x in
112 if d = 0 then c else Cop(Caddi, [c; Cconst_int (d, dbg)], dbg)
113
114 let rec add_const c n dbg =
115 if n = 0 then c
116 else match c with
117 | Cconst_int (x, _) when Misc.no_overflow_add x n -> Cconst_int (x + n, dbg)
118 | Cop(Caddi, [Cconst_int (x, _); c], _)
119 when Misc.no_overflow_add n x ->
120 add_no_overflow n x c dbg
121 | Cop(Caddi, [c; Cconst_int (x, _)], _)
122 when Misc.no_overflow_add n x ->
123 add_no_overflow n x c dbg
124 | Cop(Csubi, [Cconst_int (x, _); c], _) when Misc.no_overflow_add n x ->
125 Cop(Csubi, [Cconst_int (n + x, dbg); c], dbg)
126 | Cop(Csubi, [c; Cconst_int (x, _)], _) when Misc.no_overflow_sub n x ->
127 add_const c (n - x) dbg
128 | c -> Cop(Caddi, [c; Cconst_int (n, dbg)], dbg)
129
130 let incr_int c dbg = add_const c 1 dbg
131 let decr_int c dbg = add_const c (-1) dbg
132
133 let rec add_int c1 c2 dbg =
134 match (c1, c2) with
135 | (Cconst_int (n, _), c) | (c, Cconst_int (n, _)) ->
136 add_const c n dbg
137 | (Cop(Caddi, [c1; Cconst_int (n1, _)], _), c2) ->
138 add_const (add_int c1 c2 dbg) n1 dbg
139 | (c1, Cop(Caddi, [c2; Cconst_int (n2, _)], _)) ->
140 add_const (add_int c1 c2 dbg) n2 dbg
141 | (_, _) ->
142 Cop(Caddi, [c1; c2], dbg)
143
144 let rec sub_int c1 c2 dbg =
145 match (c1, c2) with
146 | (c1, Cconst_int (n2, _)) when n2 <> min_int ->
147 add_const c1 (-n2) dbg
148 | (c1, Cop(Caddi, [c2; Cconst_int (n2, _)], _)) when n2 <> min_int ->
149 add_const (sub_int c1 c2 dbg) (-n2) dbg
150 | (Cop(Caddi, [c1; Cconst_int (n1, _)], _), c2) ->
151 add_const (sub_int c1 c2 dbg) n1 dbg
152 | (c1, c2) ->
153 Cop(Csubi, [c1; c2], dbg)
154
155 let rec lsl_int c1 c2 dbg =
156 match (c1, c2) with
157 | (Cop(Clsl, [c; Cconst_int (n1, _)], _), Cconst_int (n2, _))
158 when n1 > 0 && n2 > 0 && n1 + n2 < size_int * 8 ->
159 Cop(Clsl, [c; Cconst_int (n1 + n2, dbg)], dbg)
160 | (Cop(Caddi, [c1; Cconst_int (n1, _)], _), Cconst_int (n2, _))
161 when Misc.no_overflow_lsl n1 n2 ->
162 add_const (lsl_int c1 c2 dbg) (n1 lsl n2) dbg
163 | (_, _) ->
164 Cop(Clsl, [c1; c2], dbg)
165
166 let is_power2 n = n = 1 lsl Misc.log2 n
167
168 and mult_power2 c n dbg = lsl_int c (Cconst_int (Misc.log2 n, dbg)) dbg
169
170 let rec mul_int c1 c2 dbg =
171 match (c1, c2) with
172 | (c, Cconst_int (0, _)) | (Cconst_int (0, _), c) ->
173 Csequence (c, Cconst_int (0, dbg))
174 | (c, Cconst_int (1, _)) | (Cconst_int (1, _), c) ->
175 c
176 | (c, Cconst_int(-1, _)) | (Cconst_int(-1, _), c) ->
177 sub_int (Cconst_int (0, dbg)) c dbg
178 | (c, Cconst_int (n, _)) when is_power2 n -> mult_power2 c n dbg
179 | (Cconst_int (n, _), c) when is_power2 n -> mult_power2 c n dbg
180 | (Cop(Caddi, [c; Cconst_int (n, _)], _), Cconst_int (k, _)) |
181 (Cconst_int (k, _), Cop(Caddi, [c; Cconst_int (n, _)], _))
182 when Misc.no_overflow_mul n k ->
183 add_const (mul_int c (Cconst_int (k, dbg)) dbg) (n * k) dbg
184 | (c1, c2) ->
185 Cop(Cmuli, [c1; c2], dbg)
186
187
188 let ignore_low_bit_int = function
189 Cop(Caddi,
190 [(Cop(Clsl, [_; Cconst_int (n, _)], _) as c); Cconst_int (1, _)], _)
191 when n > 0
192 -> c
193 | Cop(Cor, [c; Cconst_int (1, _)], _) -> c
194 | c -> c
195
196 (* removes the 1-bit sign-extension left by untag_int (tag_int c) *)
197 let ignore_high_bit_int = function
198 Cop(Casr,
199 [Cop(Clsl, [c; Cconst_int (1, _)], _); Cconst_int (1, _)], _) -> c
200 | c -> c
201
202 let lsr_int c1 c2 dbg =
203 match c2 with
204 Cconst_int (0, _) ->
205 c1
206 | Cconst_int (n, _) when n > 0 ->
207 Cop(Clsr, [ignore_low_bit_int c1; c2], dbg)
208 | _ ->
209 Cop(Clsr, [c1; c2], dbg)
210
211 let asr_int c1 c2 dbg =
212 match c2 with
213 Cconst_int (0, _) ->
214 c1
215 | Cconst_int (n, _) when n > 0 ->
216 Cop(Casr, [ignore_low_bit_int c1; c2], dbg)
217 | _ ->
218 Cop(Casr, [c1; c2], dbg)
219
220 let tag_int i dbg =
221 match i with
222 Cconst_int (n, _) ->
223 int_const dbg n
224 | Cop(Casr, [c; Cconst_int (n, _)], _) when n > 0 ->
225 Cop(Cor,
226 [asr_int c (Cconst_int (n - 1, dbg)) dbg; Cconst_int (1, dbg)],
227 dbg)
228 | c ->
229 incr_int (lsl_int c (Cconst_int (1, dbg)) dbg) dbg
230
231 let untag_int i dbg =
232 match i with
233 Cconst_int (n, _) -> Cconst_int(n asr 1, dbg)
234 | Cop(Cor, [Cop(Casr, [c; Cconst_int (n, _)], _); Cconst_int (1, _)], _)
235 when n > 0 && n < size_int * 8 ->
236 Cop(Casr, [c; Cconst_int (n+1, dbg)], dbg)
237 | Cop(Cor, [Cop(Clsr, [c; Cconst_int (n, _)], _); Cconst_int (1, _)], _)
238 when n > 0 && n < size_int * 8 ->
239 Cop(Clsr, [c; Cconst_int (n+1, dbg)], dbg)
240 | c -> asr_int c (Cconst_int (1, dbg)) dbg
241
242 let mk_if_then_else dbg cond ifso_dbg ifso ifnot_dbg ifnot =
243 match cond with
244 | Cconst_int (0, _) -> ifnot
245 | Cconst_int (1, _) -> ifso
246 | _ ->
247 Cifthenelse(cond, ifso_dbg, ifso, ifnot_dbg, ifnot, dbg)
248
249 let mk_not dbg cmm =
250 match cmm with
251 | Cop(Caddi,
252 [Cop(Clsl, [c; Cconst_int (1, _)], _); Cconst_int (1, _)], dbg') ->
253 begin
254 match c with
255 | Cop(Ccmpi cmp, [c1; c2], dbg'') ->
256 tag_int
257 (Cop(Ccmpi (negate_integer_comparison cmp), [c1; c2], dbg'')) dbg'
258 | Cop(Ccmpa cmp, [c1; c2], dbg'') ->
259 tag_int
260 (Cop(Ccmpa (negate_integer_comparison cmp), [c1; c2], dbg'')) dbg'
261 | Cop(Ccmpf cmp, [c1; c2], dbg'') ->
262 tag_int
263 (Cop(Ccmpf (negate_float_comparison cmp), [c1; c2], dbg'')) dbg'
264 | _ ->
265 (* 0 -> 3, 1 -> 1 *)
266 Cop(Csubi,
267 [Cconst_int (3, dbg); Cop(Clsl, [c; Cconst_int (1, dbg)], dbg)],
268 dbg)
269 end
270 | Cconst_int (3, _) -> Cconst_int (1, dbg)
271 | Cconst_int (1, _) -> Cconst_int (3, dbg)
272 | c ->
273 (* 1 -> 3, 3 -> 1 *)
274 Cop(Csubi, [Cconst_int (4, dbg); c], dbg)
275
276
277 let create_loop body dbg =
278 let cont = Lambda.next_raise_count () in
279 let call_cont = Cexit (cont, []) in
280 let body = Csequence (body, call_cont) in
281 Ccatch (Recursive, [cont, [], body, dbg], call_cont)
282
283 (* Turning integer divisions into multiply-high then shift.
284 The [division_parameters] function is used in module Emit for
285 those target platforms that support this optimization. *)
286
287 (* Unsigned comparison between native integers. *)
288
289 let ucompare x y = Nativeint.(compare (add x min_int) (add y min_int))
290
291 (* Unsigned division and modulus at type nativeint.
292 Algorithm: Hacker's Delight section 9.3 *)
293
294 let udivmod n d = Nativeint.(
295 if d < 0n then
296 if ucompare n d < 0 then (0n, n) else (1n, sub n d)
297 else begin
298 let q = shift_left (div (shift_right_logical n 1) d) 1 in
299 let r = sub n (mul q d) in
300 if ucompare r d >= 0 then (succ q, sub r d) else (q, r)
301 end)
302
303 (* Compute division parameters.
304 Algorithm: Hacker's Delight chapter 10, fig 10-1. *)
305
306 let divimm_parameters d = Nativeint.(
307 assert (d > 0n);
308 let twopsm1 = min_int in (* 2^31 for 32-bit archs, 2^63 for 64-bit archs *)
309 let nc = sub (pred twopsm1) (snd (udivmod twopsm1 d)) in
310 let rec loop p (q1, r1) (q2, r2) =
311 let p = p + 1 in
312 let q1 = shift_left q1 1 and r1 = shift_left r1 1 in
313 let (q1, r1) =
314 if ucompare r1 nc >= 0 then (succ q1, sub r1 nc) else (q1, r1) in
315 let q2 = shift_left q2 1 and r2 = shift_left r2 1 in
316 let (q2, r2) =
317 if ucompare r2 d >= 0 then (succ q2, sub r2 d) else (q2, r2) in
318 let delta = sub d r2 in
319 if ucompare q1 delta < 0 || (q1 = delta && r1 = 0n)
320 then loop p (q1, r1) (q2, r2)
321 else (succ q2, p - size)
322 in loop (size - 1) (udivmod twopsm1 nc) (udivmod twopsm1 d))
323
324 (* The result [(m, p)] of [divimm_parameters d] satisfies the following
325 inequality:
326
327 2^(wordsize + p) < m * d <= 2^(wordsize + p) + 2^(p + 1) (i)
328
329 from which it follows that
330
331 floor(n / d) = floor(n * m / 2^(wordsize+p))
332 if 0 <= n < 2^(wordsize-1)
333 ceil(n / d) = floor(n * m / 2^(wordsize+p)) + 1
334 if -2^(wordsize-1) <= n < 0
335
336 The correctness condition (i) above can be checked by the code below.
337 It was exhaustively tested for values of d from 2 to 10^9 in the
338 wordsize = 64 case.
339
340 let add2 (xh, xl) (yh, yl) =
341 let zl = add xl yl and zh = add xh yh in
342 ((if ucompare zl xl < 0 then succ zh else zh), zl)
343
344 let shl2 (xh, xl) n =
345 assert (0 < n && n < size + size);
346 if n < size
347 then (logor (shift_left xh n) (shift_right_logical xl (size - n)),
348 shift_left xl n)
349 else (shift_left xl (n - size), 0n)
350
351 let mul2 x y =
352 let halfsize = size / 2 in
353 let halfmask = pred (shift_left 1n halfsize) in
354 let xl = logand x halfmask and xh = shift_right_logical x halfsize in
355 let yl = logand y halfmask and yh = shift_right_logical y halfsize in
356 add2 (mul xh yh, 0n)
357 (add2 (shl2 (0n, mul xl yh) halfsize)
358 (add2 (shl2 (0n, mul xh yl) halfsize)
359 (0n, mul xl yl)))
360
361 let ucompare2 (xh, xl) (yh, yl) =
362 let c = ucompare xh yh in if c = 0 then ucompare xl yl else c
363
364 let validate d m p =
365 let md = mul2 m d in
366 let one2 = (0n, 1n) in
367 let twoszp = shl2 one2 (size + p) in
368 let twop1 = shl2 one2 (p + 1) in
369 ucompare2 twoszp md < 0 && ucompare2 md (add2 twoszp twop1) <= 0
370 *)
371
372 let raise_symbol dbg symb =
373 Cop(Craise Lambda.Raise_regular, [Cconst_symbol (symb, dbg)], dbg)
374
375 let rec div_int c1 c2 is_safe dbg =
376 match (c1, c2) with
377 (c1, Cconst_int (0, _)) ->
378 Csequence(c1, raise_symbol dbg "caml_exn_Division_by_zero")
379 | (c1, Cconst_int (1, _)) ->
380 c1
381 | (Cconst_int (n1, _), Cconst_int (n2, _)) ->
382 Cconst_int (n1 / n2, dbg)
383 | (c1, Cconst_int (n, _)) when n <> min_int ->
384 let l = Misc.log2 n in
385 if n = 1 lsl l then
386 (* Algorithm:
387 t = shift-right-signed(c1, l - 1)
388 t = shift-right(t, W - l)
389 t = c1 + t
390 res = shift-right-signed(c1 + t, l)
391 *)
392 Cop(Casr, [bind "dividend" c1 (fun c1 ->
393 let t = asr_int c1 (Cconst_int (l - 1, dbg)) dbg in
394 let t =
395 lsr_int t (Cconst_int (Nativeint.size - l, dbg)) dbg
396 in
397 add_int c1 t dbg);
398 Cconst_int (l, dbg)], dbg)
399 else if n < 0 then
400 sub_int (Cconst_int (0, dbg))
401 (div_int c1 (Cconst_int (-n, dbg)) is_safe dbg)
402 dbg
403 else begin
404 let (m, p) = divimm_parameters (Nativeint.of_int n) in
405 (* Algorithm:
406 t = multiply-high-signed(c1, m)
407 if m < 0, t = t + c1
408 if p > 0, t = shift-right-signed(t, p)
409 res = t + sign-bit(c1)
410 *)
411 bind "dividend" c1 (fun c1 ->
412 let t = Cop(Cmulhi, [c1; Cconst_natint (m, dbg)], dbg) in
413 let t = if m < 0n then Cop(Caddi, [t; c1], dbg) else t in
414 let t =
415 if p > 0 then Cop(Casr, [t; Cconst_int (p, dbg)], dbg) else t
416 in
417 add_int t (lsr_int c1 (Cconst_int (Nativeint.size - 1, dbg)) dbg) dbg)
418 end
419 | (c1, c2) when !Clflags.unsafe || is_safe = Lambda.Unsafe ->
420 Cop(Cdivi, [c1; c2], dbg)
421 | (c1, c2) ->
422 bind "divisor" c2 (fun c2 ->
423 bind "dividend" c1 (fun c1 ->
424 Cifthenelse(c2,
425 dbg,
426 Cop(Cdivi, [c1; c2], dbg),
427 dbg,
428 raise_symbol dbg "caml_exn_Division_by_zero",
429 dbg)))
430
431 let mod_int c1 c2 is_safe dbg =
432 match (c1, c2) with
433 (c1, Cconst_int (0, _)) ->
434 Csequence(c1, raise_symbol dbg "caml_exn_Division_by_zero")
435 | (c1, Cconst_int ((1 | (-1)), _)) ->
436 Csequence(c1, Cconst_int (0, dbg))
437 | (Cconst_int (n1, _), Cconst_int (n2, _)) ->
438 Cconst_int (n1 mod n2, dbg)
439 | (c1, (Cconst_int (n, _) as c2)) when n <> min_int ->
440 let l = Misc.log2 n in
441 if n = 1 lsl l then
442 (* Algorithm:
443 t = shift-right-signed(c1, l - 1)
444 t = shift-right(t, W - l)
445 t = c1 + t
446 t = bit-and(t, -n)
447 res = c1 - t
448 *)
449 bind "dividend" c1 (fun c1 ->
450 let t = asr_int c1 (Cconst_int (l - 1, dbg)) dbg in
451 let t = lsr_int t (Cconst_int (Nativeint.size - l, dbg)) dbg in
452 let t = add_int c1 t dbg in
453 let t = Cop(Cand, [t; Cconst_int (-n, dbg)], dbg) in
454 sub_int c1 t dbg)
455 else
456 bind "dividend" c1 (fun c1 ->
457 sub_int c1 (mul_int (div_int c1 c2 is_safe dbg) c2 dbg) dbg)
458 | (c1, c2) when !Clflags.unsafe || is_safe = Lambda.Unsafe ->
459 (* Flambda already generates that test *)
460 Cop(Cmodi, [c1; c2], dbg)
461 | (c1, c2) ->
462 bind "divisor" c2 (fun c2 ->
463 bind "dividend" c1 (fun c1 ->
464 Cifthenelse(c2,
465 dbg,
466 Cop(Cmodi, [c1; c2], dbg),
467 dbg,
468 raise_symbol dbg "caml_exn_Division_by_zero",
469 dbg)))
470
471 (* Division or modulo on boxed integers. The overflow case min_int / -1
472 can occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *)
473
474 let is_different_from x = function
475 Cconst_int (n, _) -> n <> x
476 | Cconst_natint (n, _) -> n <> Nativeint.of_int x
477 | _ -> false
478
479 let safe_divmod_bi mkop is_safe mkm1 c1 c2 bi dbg =
480 bind "dividend" c1 (fun c1 ->
481 bind "divisor" c2 (fun c2 ->
482 let c = mkop c1 c2 is_safe dbg in
483 if Arch.division_crashes_on_overflow
484 && (size_int = 4 || bi <> Primitive.Pint32)
485 && not (is_different_from (-1) c2)
486 then
487 Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int (-1, dbg)], dbg),
488 dbg, c,
489 dbg, mkm1 c1 dbg,
490 dbg)
491 else
492 c))
493
494 let safe_div_bi is_safe =
495 safe_divmod_bi div_int is_safe
496 (fun c1 dbg -> Cop(Csubi, [Cconst_int (0, dbg); c1], dbg))
497
498 let safe_mod_bi is_safe =
499 safe_divmod_bi mod_int is_safe (fun _ dbg -> Cconst_int (0, dbg))
500
501 (* Bool *)
502
503 let test_bool dbg cmm =
504 match cmm with
505 | Cop(Caddi, [Cop(Clsl, [c; Cconst_int (1, _)], _); Cconst_int (1, _)], _) ->
506 c
507 | Cconst_int (n, dbg) ->
508 if n = 1 then
509 Cconst_int (0, dbg)
510 else
511 Cconst_int (1, dbg)
512 | c -> Cop(Ccmpi Cne, [c; Cconst_int (1, dbg)], dbg)
513
514 (* Float *)
515
516 let box_float dbg c = Cop(Calloc, [alloc_float_header dbg; c], dbg)
517
518 let unbox_float dbg =
519 map_tail
520 (function
521 | Cop(Calloc, [Cblockheader (hdr, _); c], _)
522 when Nativeint.equal hdr float_header ->
523 c
524 | Cconst_symbol (s, _dbg) as cmm ->
525 begin match Cmmgen_state.structured_constant_of_sym s with
526 | Some (Uconst_float x) ->
527 Cconst_float (x, dbg) (* or keep _dbg? *)
528 | _ ->
529 Cop(Cload (Double_u, Immutable), [cmm], dbg)
530 end
531 | cmm -> Cop(Cload (Double_u, Immutable), [cmm], dbg)
532 )
533
534 (* Complex *)
535
536 let box_complex dbg c_re c_im =
537 Cop(Calloc, [alloc_floatarray_header 2 dbg; c_re; c_im], dbg)
538
539 let complex_re c dbg = Cop(Cload (Double_u, Immutable), [c], dbg)
540 let complex_im c dbg = Cop(Cload (Double_u, Immutable),
541 [Cop(Cadda, [c; Cconst_int (size_float, dbg)], dbg)],
542 dbg)
543
544 (* Unit *)
545
546 let return_unit dbg c = Csequence(c, Cconst_pointer (1, dbg))
547
548 let rec remove_unit = function
549 Cconst_pointer (1, _) -> Ctuple []
550 | Csequence(c, Cconst_pointer (1, _)) -> c
551 | Csequence(c1, c2) ->
552 Csequence(c1, remove_unit c2)
553 | Cifthenelse(cond, ifso_dbg, ifso, ifnot_dbg, ifnot, dbg) ->
554 Cifthenelse(cond,
555 ifso_dbg, remove_unit ifso,
556 ifnot_dbg,
557 remove_unit ifnot, dbg)
558 | Cswitch(sel, index, cases, dbg) ->
559 Cswitch(sel, index,
560 Array.map (fun (case, dbg) -> remove_unit case, dbg) cases,
561 dbg)
562 | Ccatch(rec_flag, handlers, body) ->
563 let map_h (n, ids, handler, dbg) = (n, ids, remove_unit handler, dbg) in
564 Ccatch(rec_flag, List.map map_h handlers, remove_unit body)
565 | Ctrywith(body, exn, handler, dbg) ->
566 Ctrywith(remove_unit body, exn, remove_unit handler, dbg)
567 | Clet(id, c1, c2) ->
568 Clet(id, c1, remove_unit c2)
569 | Cop(Capply _mty, args, dbg) ->
570 Cop(Capply typ_void, args, dbg)
571 | Cop(Cextcall(proc, _mty, alloc, label_after), args, dbg) ->
572 Cop(Cextcall(proc, typ_void, alloc, label_after), args, dbg)
573 | Cexit (_,_) as c -> c
574 | Ctuple [] as c -> c
575 | c -> Csequence(c, Ctuple [])
576
577 (* Access to block fields *)
578
579 let field_address ptr n dbg =
580 if n = 0
581 then ptr
582 else Cop(Cadda, [ptr; Cconst_int(n * size_addr, dbg)], dbg)
583
584 let get_field_gen mut ptr n dbg =
585 Cop(Cload (Word_val, mut), [field_address ptr n dbg], dbg)
586
587 let set_field ptr n newval init dbg =
588 Cop(Cstore (Word_val, init), [field_address ptr n dbg; newval], dbg)
589
590 let non_profinfo_mask =
591 if Config.profinfo
592 then (1 lsl (64 - Config.profinfo_width)) - 1
593 else 0 (* [non_profinfo_mask] is unused in this case *)
594
595 let get_header ptr dbg =
596 (* We cannot deem this as [Immutable] due to the presence of [Obj.truncate]
597 and [Obj.set_tag]. *)
598 Cop(Cload (Word_int, Mutable),
599 [Cop(Cadda, [ptr; Cconst_int(-size_int, dbg)], dbg)], dbg)
600
601 let get_header_without_profinfo ptr dbg =
602 if Config.profinfo then
603 Cop(Cand, [get_header ptr dbg; Cconst_int (non_profinfo_mask, dbg)], dbg)
604 else
605 get_header ptr dbg
606
607 let tag_offset =
608 if big_endian then -1 else -size_int
609
610 let get_tag ptr dbg =
611 if Proc.word_addressed then (* If byte loads are slow *)
612 Cop(Cand, [get_header ptr dbg; Cconst_int (255, dbg)], dbg)
613 else (* If byte loads are efficient *)
614 (* Same comment as [get_header] above *)
615 Cop(Cload (Byte_unsigned, Mutable),
616 [Cop(Cadda, [ptr; Cconst_int(tag_offset, dbg)], dbg)], dbg)
617
618 let get_size ptr dbg =
619 Cop(Clsr, [get_header_without_profinfo ptr dbg; Cconst_int (10, dbg)], dbg)
620
621 (* Array indexing *)
622
623 let log2_size_addr = Misc.log2 size_addr
624 let log2_size_float = Misc.log2 size_float
625
626 let wordsize_shift = 9
627 let numfloat_shift = 9 + log2_size_float - log2_size_addr
628
629 let is_addr_array_hdr hdr dbg =
630 Cop(Ccmpi Cne,
631 [Cop(Cand, [hdr; Cconst_int (255, dbg)], dbg); floatarray_tag dbg],
632 dbg)
633
634 let is_addr_array_ptr ptr dbg =
635 Cop(Ccmpi Cne, [get_tag ptr dbg; floatarray_tag dbg], dbg)
636
637 let addr_array_length_shifted hdr dbg =
638 Cop(Clsr, [hdr; Cconst_int (wordsize_shift, dbg)], dbg)
639 let float_array_length_shifted hdr dbg =
640 Cop(Clsr, [hdr; Cconst_int (numfloat_shift, dbg)], dbg)
641
642 let lsl_const c n dbg =
643 if n = 0 then c
644 else Cop(Clsl, [c; Cconst_int (n, dbg)], dbg)
645
646 (* Produces a pointer to the element of the array [ptr] on the position [ofs]
647 with the given element [log2size] log2 element size. [ofs] is given as a
648 tagged int expression.
649 The optional ?typ argument is the C-- type of the result.
650 By default, it is Addr, meaning we are constructing a derived pointer
651 into the heap. If we know the pointer is outside the heap
652 (this is the case for bigarray indexing), we give type Int instead. *)
653
654 let array_indexing ?typ log2size ptr ofs dbg =
655 let add =
656 match typ with
657 | None | Some Addr -> Cadda
658 | Some Int -> Caddi
659 | _ -> assert false in
660 match ofs with
661 | Cconst_int (n, _) ->
662 let i = n asr 1 in
663 if i = 0 then ptr
664 else Cop(add, [ptr; Cconst_int(i lsl log2size, dbg)], dbg)
665 | Cop(Caddi,
666 [Cop(Clsl, [c; Cconst_int (1, _)], _); Cconst_int (1, _)], dbg') ->
667 Cop(add, [ptr; lsl_const c log2size dbg], dbg')
668 | Cop(Caddi, [c; Cconst_int (n, _)], dbg') when log2size = 0 ->
669 Cop(add,
670 [Cop(add, [ptr; untag_int c dbg], dbg); Cconst_int (n asr 1, dbg)],
671 dbg')
672 | Cop(Caddi, [c; Cconst_int (n, _)], _) ->
673 Cop(add, [Cop(add, [ptr; lsl_const c (log2size - 1) dbg], dbg);
674 Cconst_int((n-1) lsl (log2size - 1), dbg)], dbg)
675 | _ when log2size = 0 ->
676 Cop(add, [ptr; untag_int ofs dbg], dbg)
677 | _ ->
678 Cop(add, [Cop(add, [ptr; lsl_const ofs (log2size - 1) dbg], dbg);
679 Cconst_int((-1) lsl (log2size - 1), dbg)], dbg)
680
681 let addr_array_ref arr ofs dbg =
682 Cop(Cload (Word_val, Mutable),
683 [array_indexing log2_size_addr arr ofs dbg], dbg)
684 let int_array_ref arr ofs dbg =
685 Cop(Cload (Word_int, Mutable),
686 [array_indexing log2_size_addr arr ofs dbg], dbg)
687 let unboxed_float_array_ref arr ofs dbg =
688 Cop(Cload (Double_u, Mutable),
689 [array_indexing log2_size_float arr ofs dbg], dbg)
690 let float_array_ref arr ofs dbg =
691 box_float dbg (unboxed_float_array_ref arr ofs dbg)
692
693 let addr_array_set arr ofs newval dbg =
694 Cop(Cextcall("caml_modify", typ_void, false, None),
695 [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
696 let addr_array_initialize arr ofs newval dbg =
697 Cop(Cextcall("caml_initialize", typ_void, false, None),
698 [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
699 let int_array_set arr ofs newval dbg =
700 Cop(Cstore (Word_int, Lambda.Assignment),
701 [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
702 let float_array_set arr ofs newval dbg =
703 Cop(Cstore (Double_u, Lambda.Assignment),
704 [array_indexing log2_size_float arr ofs dbg; newval], dbg)
705
706 (* String length *)
707
708 (* Length of string block *)
709
710 let string_length exp dbg =
711 bind "str" exp (fun str ->
712 let tmp_var = V.create_local "tmp" in
713 Clet(VP.create tmp_var,
714 Cop(Csubi,
715 [Cop(Clsl,
716 [get_size str dbg;
717 Cconst_int (log2_size_addr, dbg)],
718 dbg);
719 Cconst_int (1, dbg)],
720 dbg),
721 Cop(Csubi,
722 [Cvar tmp_var;
723 Cop(Cload (Byte_unsigned, Mutable),
724 [Cop(Cadda, [str; Cvar tmp_var], dbg)], dbg)], dbg)))
725
726 let bigstring_length ba dbg =
727 Cop(Cload (Word_int, Mutable), [field_address ba 5 dbg], dbg)
728
729 (* Message sending *)
730
731 let lookup_tag obj tag dbg =
732 bind "tag" tag (fun tag ->
733 Cop(Cextcall("caml_get_public_method", typ_val, false, None),
734 [obj; tag],
735 dbg))
736
737 let lookup_label obj lab dbg =
738 bind "lab" lab (fun lab ->
739 let table = Cop (Cload (Word_val, Mutable), [obj], dbg) in
740 addr_array_ref table lab dbg)
741
742 let call_cached_method obj tag cache pos args dbg =
743 let arity = List.length args in
744 let cache = array_indexing log2_size_addr cache pos dbg in
745 Compilenv.need_send_fun arity;
746 Cop(Capply typ_val,
747 Cconst_symbol("caml_send" ^ Int.to_string arity, dbg) ::
748 obj :: tag :: cache :: args,
749 dbg)
750
751 (* Allocation *)
752
753 let make_alloc_generic set_fn dbg tag wordsize args =
754 if wordsize <= Config.max_young_wosize then
755 Cop(Calloc, Cblockheader(block_header tag wordsize, dbg) :: args, dbg)
756 else begin
757 let id = V.create_local "*alloc*" in
758 let rec fill_fields idx = function
759 [] -> Cvar id
760 | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int (idx, dbg)) e1 dbg,
761 fill_fields (idx + 2) el) in
762 Clet(VP.create id,
763 Cop(Cextcall("caml_alloc", typ_val, true, None),
764 [Cconst_int (wordsize, dbg); Cconst_int (tag, dbg)], dbg),
765 fill_fields 1 args)
766 end
767
768 let make_alloc dbg tag args =
769 let addr_array_init arr ofs newval dbg =
770 Cop(Cextcall("caml_initialize", typ_void, false, None),
771 [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
772 in
773 make_alloc_generic addr_array_init dbg tag (List.length args) args
774
775 let make_float_alloc dbg tag args =
776 make_alloc_generic float_array_set dbg tag
777 (List.length args * size_float / size_addr) args
778
779 (* Bounds checking *)
780
781 let make_checkbound dbg = function
782 | [Cop(Clsr, [a1; Cconst_int (n, _)], _); Cconst_int (m, _)]
783 when (m lsl n) > n ->
784 Cop(Ccheckbound, [a1; Cconst_int(m lsl n + 1 lsl n - 1, dbg)], dbg)
785 | args ->
786 Cop(Ccheckbound, args, dbg)
787
788 (* Record application and currying functions *)
789
790 let apply_function_sym n =
791 Compilenv.need_apply_fun n; "caml_apply" ^ Int.to_string n
792 let curry_function_sym n =
793 Compilenv.need_curry_fun n;
794 if n >= 0
795 then "caml_curry" ^ Int.to_string n
796 else "caml_tuplify" ^ Int.to_string (-n)
797
798 (* Big arrays *)
799
800 let bigarray_elt_size : Lambda.bigarray_kind -> int = function
801 Pbigarray_unknown -> assert false
802 | Pbigarray_float32 -> 4
803 | Pbigarray_float64 -> 8
804 | Pbigarray_sint8 -> 1
805 | Pbigarray_uint8 -> 1
806 | Pbigarray_sint16 -> 2
807 | Pbigarray_uint16 -> 2
808 | Pbigarray_int32 -> 4
809 | Pbigarray_int64 -> 8
810 | Pbigarray_caml_int -> size_int
811 | Pbigarray_native_int -> size_int
812 | Pbigarray_complex32 -> 8
813 | Pbigarray_complex64 -> 16
814
815 (* Produces a pointer to the element of the bigarray [b] on the position
816 [args]. [args] is given as a list of tagged int expressions, one per array
817 dimension. *)
818 let bigarray_indexing unsafe elt_kind layout b args dbg =
819 let check_ba_bound bound idx v =
820 Csequence(make_checkbound dbg [bound;idx], v) in
821 (* Validates the given multidimensional offset against the array bounds and
822 transforms it into a one dimensional offset. The offsets are expressions
823 evaluating to tagged int. *)
824 let rec ba_indexing dim_ofs delta_ofs = function
825 [] -> assert false
826 | [arg] ->
827 if unsafe then arg
828 else
829 bind "idx" arg (fun idx ->
830 (* Load the untagged int bound for the given dimension *)
831 let bound =
832 Cop(Cload (Word_int, Mutable),
833 [field_address b dim_ofs dbg], dbg)
834 in
835 let idxn = untag_int idx dbg in
836 check_ba_bound bound idxn idx)
837 | arg1 :: argl ->
838 (* The remainder of the list is transformed into a one dimensional offset
839 *)
840 let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in
841 (* Load the untagged int bound for the given dimension *)
842 let bound =
843 Cop(Cload (Word_int, Mutable),
844 [field_address b dim_ofs dbg], dbg)
845 in
846 if unsafe then add_int (mul_int (decr_int rem dbg) bound dbg) arg1 dbg
847 else
848 bind "idx" arg1 (fun idx ->
849 bind "bound" bound (fun bound ->
850 let idxn = untag_int idx dbg in
851 (* [offset = rem * (tag_int bound) + idx] *)
852 let offset =
853 add_int (mul_int (decr_int rem dbg) bound dbg) idx dbg
854 in
855 check_ba_bound bound idxn offset)) in
856 (* The offset as an expression evaluating to int *)
857 let offset =
858 match (layout : Lambda.bigarray_layout) with
859 Pbigarray_unknown_layout ->
860 assert false
861 | Pbigarray_c_layout ->
862 ba_indexing (4 + List.length args) (-1) (List.rev args)
863 | Pbigarray_fortran_layout ->
864 ba_indexing 5 1
865 (List.map (fun idx -> sub_int idx (Cconst_int (2, dbg)) dbg) args)
866 and elt_size =
867 bigarray_elt_size elt_kind in
868 (* [array_indexing] can simplify the given expressions *)
869 array_indexing ~typ:Addr (Misc.log2 elt_size)
870 (Cop(Cload (Word_int, Mutable),
871 [field_address b 1 dbg], dbg)) offset dbg
872
873 let bigarray_word_kind : Lambda.bigarray_kind -> memory_chunk = function
874 Pbigarray_unknown -> assert false
875 | Pbigarray_float32 -> Single
876 | Pbigarray_float64 -> Double
877 | Pbigarray_sint8 -> Byte_signed
878 | Pbigarray_uint8 -> Byte_unsigned
879 | Pbigarray_sint16 -> Sixteen_signed
880 | Pbigarray_uint16 -> Sixteen_unsigned
881 | Pbigarray_int32 -> Thirtytwo_signed
882 | Pbigarray_int64 -> Word_int
883 | Pbigarray_caml_int -> Word_int
884 | Pbigarray_native_int -> Word_int
885 | Pbigarray_complex32 -> Single
886 | Pbigarray_complex64 -> Double
887
888 let bigarray_get unsafe elt_kind layout b args dbg =
889 bind "ba" b (fun b ->
890 match (elt_kind : Lambda.bigarray_kind) with
891 Pbigarray_complex32 | Pbigarray_complex64 ->
892 let kind = bigarray_word_kind elt_kind in
893 let sz = bigarray_elt_size elt_kind / 2 in
894 bind "addr"
895 (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
896 bind "reval"
897 (Cop(Cload (kind, Mutable), [addr], dbg)) (fun reval ->
898 bind "imval"
899 (Cop(Cload (kind, Mutable),
900 [Cop(Cadda, [addr; Cconst_int (sz, dbg)], dbg)], dbg))
901 (fun imval -> box_complex dbg reval imval)))
902 | _ ->
903 Cop(Cload (bigarray_word_kind elt_kind, Mutable),
904 [bigarray_indexing unsafe elt_kind layout b args dbg],
905 dbg))
906
907 let bigarray_set unsafe elt_kind layout b args newval dbg =
908 bind "ba" b (fun b ->
909 match (elt_kind : Lambda.bigarray_kind) with
910 Pbigarray_complex32 | Pbigarray_complex64 ->
911 let kind = bigarray_word_kind elt_kind in
912 let sz = bigarray_elt_size elt_kind / 2 in
913 bind "newval" newval (fun newv ->
914 bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg)
915 (fun addr ->
916 Csequence(
917 Cop(Cstore (kind, Assignment), [addr; complex_re newv dbg], dbg),
918 Cop(Cstore (kind, Assignment),
919 [Cop(Cadda, [addr; Cconst_int (sz, dbg)], dbg);
920 complex_im newv dbg],
921 dbg))))
922 | _ ->
923 Cop(Cstore (bigarray_word_kind elt_kind, Assignment),
924 [bigarray_indexing unsafe elt_kind layout b args dbg; newval],
925 dbg))
926
927 (* the three functions below assume either 32-bit or 64-bit words *)
928 let () = assert (size_int = 4 || size_int = 8)
929
930 (* low_32 x is a value which agrees with x on at least the low 32 bits *)
931 let rec low_32 dbg = function
932 | x when size_int = 4 -> x
933 (* Ignore sign and zero extensions, which do not affect the low bits *)
934 | Cop(Casr, [Cop(Clsl, [x; Cconst_int (32, _)], _);
935 Cconst_int (32, _)], _)
936 | Cop(Cand, [x; Cconst_natint (0xFFFFFFFFn, _)], _) ->
937 low_32 dbg x
938 | Clet(id, e, body) ->
939 Clet(id, e, low_32 dbg body)
940 | x -> x
941
942 (* sign_extend_32 sign-extends values from 32 bits to the word size.
943 (if the word size is 32, this is a no-op) *)
944 let sign_extend_32 dbg e =
945 if size_int = 4 then e else
946 Cop(Casr, [Cop(Clsl, [low_32 dbg e; Cconst_int(32, dbg)], dbg);
947 Cconst_int(32, dbg)], dbg)
948
949 (* zero_extend_32 zero-extends values from 32 bits to the word size.
950 (if the word size is 32, this is a no-op) *)
951 let zero_extend_32 dbg e =
952 if size_int = 4 then e else
953 Cop(Cand, [low_32 dbg e; Cconst_natint(0xFFFFFFFFn, dbg)], dbg)
954
955 (* Boxed integers *)
956
957 let operations_boxed_int (bi : Primitive.boxed_integer) =
958 match bi with
959 Pnativeint -> caml_nativeint_ops
960 | Pint32 -> caml_int32_ops
961 | Pint64 -> caml_int64_ops
962
963 let alloc_header_boxed_int (bi : Primitive.boxed_integer) =
964 match bi with
965 Pnativeint -> alloc_boxedintnat_header
966 | Pint32 -> alloc_boxedint32_header
967 | Pint64 -> alloc_boxedint64_header
968
969 let box_int_gen dbg (bi : Primitive.boxed_integer) arg =
970 let arg' =
971 if bi = Primitive.Pint32 && size_int = 8 then
972 if big_endian
973 then Cop(Clsl, [arg; Cconst_int (32, dbg)], dbg)
974 else sign_extend_32 dbg arg
975 else arg
976 in
977 Cop(Calloc, [alloc_header_boxed_int bi dbg;
978 Cconst_symbol(operations_boxed_int bi, dbg);
979 arg'], dbg)
980
981 let split_int64_for_32bit_target arg dbg =
982 bind "split_int64" arg (fun arg ->
983 let first = Cop (Cadda, [Cconst_int (size_int, dbg); arg], dbg) in
984 let second = Cop (Cadda, [Cconst_int (2 * size_int, dbg); arg], dbg) in
985 Ctuple [Cop (Cload (Thirtytwo_unsigned, Mutable), [first], dbg);
986 Cop (Cload (Thirtytwo_unsigned, Mutable), [second], dbg)])
987
988 let alloc_matches_boxed_int bi ~hdr ~ops =
989 match (bi : Primitive.boxed_integer), hdr, ops with
990 | Pnativeint, Cblockheader (hdr, _dbg), Cconst_symbol (sym, _) ->
991 Nativeint.equal hdr boxedintnat_header
992 && String.equal sym caml_nativeint_ops
993 | Pint32, Cblockheader (hdr, _dbg), Cconst_symbol (sym, _) ->
994 Nativeint.equal hdr boxedint32_header
995 && String.equal sym caml_int32_ops
996 | Pint64, Cblockheader (hdr, _dbg), Cconst_symbol (sym, _) ->
997 Nativeint.equal hdr boxedint64_header
998 && String.equal sym caml_int64_ops
999 | (Pnativeint | Pint32 | Pint64), _, _ -> false
1000
1001 let unbox_int dbg bi =
1002 let default arg =
1003 if size_int = 4 && bi = Primitive.Pint64 then
1004 split_int64_for_32bit_target arg dbg
1005 else
1006 Cop(
1007 Cload((if bi = Primitive.Pint32 then Thirtytwo_signed else Word_int),
1008 Immutable),
1009 [Cop(Cadda, [arg; Cconst_int (size_addr, dbg)], dbg)], dbg)
1010 in
1011 map_tail
1012 (function
1013 | Cop(Calloc,
1014 [hdr; ops;
1015 Cop(Clsl, [contents; Cconst_int (32, _)], _dbg')], _dbg)
1016 when bi = Primitive.Pint32 && size_int = 8 && big_endian
1017 && alloc_matches_boxed_int bi ~hdr ~ops ->
1018 (* Force sign-extension of low 32 bits *)
1019 sign_extend_32 dbg contents
1020 | Cop(Calloc,
1021 [hdr; ops; contents], _dbg)
1022 when bi = Primitive.Pint32 && size_int = 8 && not big_endian
1023 && alloc_matches_boxed_int bi ~hdr ~ops ->
1024 (* Force sign-extension of low 32 bits *)
1025 sign_extend_32 dbg contents
1026 | Cop(Calloc, [hdr; ops; contents], _dbg)
1027 when alloc_matches_boxed_int bi ~hdr ~ops ->
1028 contents
1029 | Cconst_symbol (s, _dbg) as cmm ->
1030 begin match Cmmgen_state.structured_constant_of_sym s, bi with
1031 | Some (Uconst_nativeint n), Primitive.Pnativeint ->
1032 Cconst_natint (n, dbg)
1033 | Some (Uconst_int32 n), Primitive.Pint32 ->
1034 Cconst_natint (Nativeint.of_int32 n, dbg)
1035 | Some (Uconst_int64 n), Primitive.Pint64 ->
1036 if size_int = 8 then
1037 Cconst_natint (Int64.to_nativeint n, dbg)
1038 else
1039 let low = Int64.to_nativeint n in
1040 let high =
1041 Int64.to_nativeint (Int64.shift_right_logical n 32)
1042 in
1043 if big_endian then
1044 Ctuple [Cconst_natint (high, dbg); Cconst_natint (low, dbg)]
1045 else
1046 Ctuple [Cconst_natint (low, dbg); Cconst_natint (high, dbg)]
1047 | _ ->
1048 default cmm
1049 end
1050 | cmm ->
1051 default cmm
1052 )
1053
1054 let make_unsigned_int bi arg dbg =
1055 if bi = Primitive.Pint32 && size_int = 8
1056 then zero_extend_32 dbg arg
1057 else arg
1058
1059 let unaligned_load_16 ptr idx dbg =
1060 if Arch.allow_unaligned_access
1061 then Cop(Cload (Sixteen_unsigned, Mutable), [add_int ptr idx dbg], dbg)
1062 else
1063 let cconst_int i = Cconst_int (i, dbg) in
1064 let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in
1065 let v2 = Cop(Cload (Byte_unsigned, Mutable),
1066 [add_int (add_int ptr idx dbg) (cconst_int 1) dbg], dbg) in
1067 let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in
1068 Cop(Cor, [lsl_int b1 (cconst_int 8) dbg; b2], dbg)
1069
1070 let unaligned_set_16 ptr idx newval dbg =
1071 if Arch.allow_unaligned_access
1072 then
1073 Cop(Cstore (Sixteen_unsigned, Assignment),
1074 [add_int ptr idx dbg; newval], dbg)
1075 else
1076 let cconst_int i = Cconst_int (i, dbg) in
1077 let v1 =
1078 Cop(Cand, [Cop(Clsr, [newval; cconst_int 8], dbg);
1079 cconst_int 0xFF], dbg)
1080 in
1081 let v2 = Cop(Cand, [newval; cconst_int 0xFF], dbg) in
1082 let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in
1083 Csequence(
1084 Cop(Cstore (Byte_unsigned, Assignment), [add_int ptr idx dbg; b1], dbg),
1085 Cop(Cstore (Byte_unsigned, Assignment),
1086 [add_int (add_int ptr idx dbg) (cconst_int 1) dbg; b2], dbg))
1087
1088 let unaligned_load_32 ptr idx dbg =
1089 if Arch.allow_unaligned_access
1090 then Cop(Cload (Thirtytwo_unsigned, Mutable), [add_int ptr idx dbg], dbg)
1091 else
1092 let cconst_int i = Cconst_int (i, dbg) in
1093 let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in
1094 let v2 = Cop(Cload (Byte_unsigned, Mutable),
1095 [add_int (add_int ptr idx dbg) (cconst_int 1) dbg], dbg)
1096 in
1097 let v3 = Cop(Cload (Byte_unsigned, Mutable),
1098 [add_int (add_int ptr idx dbg) (cconst_int 2) dbg], dbg)
1099 in
1100 let v4 = Cop(Cload (Byte_unsigned, Mutable),
1101 [add_int (add_int ptr idx dbg) (cconst_int 3) dbg], dbg)
1102 in
1103 let b1, b2, b3, b4 =
1104 if Arch.big_endian
1105 then v1, v2, v3, v4
1106 else v4, v3, v2, v1 in
1107 Cop(Cor,
1108 [Cop(Cor, [lsl_int b1 (cconst_int 24) dbg;
1109 lsl_int b2 (cconst_int 16) dbg], dbg);
1110 Cop(Cor, [lsl_int b3 (cconst_int 8) dbg; b4], dbg)],
1111 dbg)
1112
1113 let unaligned_set_32 ptr idx newval dbg =
1114 if Arch.allow_unaligned_access
1115 then
1116 Cop(Cstore (Thirtytwo_unsigned, Assignment), [add_int ptr idx dbg; newval],
1117 dbg)
1118 else
1119 let cconst_int i = Cconst_int (i, dbg) in
1120 let v1 =
1121 Cop(Cand, [Cop(Clsr, [newval; cconst_int 24], dbg); cconst_int 0xFF], dbg)
1122 in
1123 let v2 =
1124 Cop(Cand, [Cop(Clsr, [newval; cconst_int 16], dbg); cconst_int 0xFF], dbg)
1125 in
1126 let v3 =
1127 Cop(Cand, [Cop(Clsr, [newval; cconst_int 8], dbg); cconst_int 0xFF], dbg)
1128 in
1129 let v4 = Cop(Cand, [newval; cconst_int 0xFF], dbg) in
1130 let b1, b2, b3, b4 =
1131 if Arch.big_endian
1132 then v1, v2, v3, v4
1133 else v4, v3, v2, v1 in
1134 Csequence(
1135 Csequence(
1136 Cop(Cstore (Byte_unsigned, Assignment),
1137 [add_int ptr idx dbg; b1], dbg),
1138 Cop(Cstore (Byte_unsigned, Assignment),
1139 [add_int (add_int ptr idx dbg) (cconst_int 1) dbg; b2],
1140 dbg)),
1141 Csequence(
1142 Cop(Cstore (Byte_unsigned, Assignment),
1143 [add_int (add_int ptr idx dbg) (cconst_int 2) dbg; b3],
1144 dbg),
1145 Cop(Cstore (Byte_unsigned, Assignment),
1146 [add_int (add_int ptr idx dbg) (cconst_int 3) dbg; b4],
1147 dbg)))
1148
1149 let unaligned_load_64 ptr idx dbg =
1150 assert(size_int = 8);
1151 if Arch.allow_unaligned_access
1152 then Cop(Cload (Word_int, Mutable), [add_int ptr idx dbg], dbg)
1153 else
1154 let cconst_int i = Cconst_int (i, dbg) in
1155 let v1 = Cop(Cload (Byte_unsigned, Mutable), [add_int ptr idx dbg], dbg) in
1156 let v2 = Cop(Cload (Byte_unsigned, Mutable),
1157 [add_int (add_int ptr idx dbg) (cconst_int 1) dbg], dbg) in
1158 let v3 = Cop(Cload (Byte_unsigned, Mutable),
1159 [add_int (add_int ptr idx dbg) (cconst_int 2) dbg], dbg) in
1160 let v4 = Cop(Cload (Byte_unsigned, Mutable),
1161 [add_int (add_int ptr idx dbg) (cconst_int 3) dbg], dbg) in
1162 let v5 = Cop(Cload (Byte_unsigned, Mutable),
1163 [add_int (add_int ptr idx dbg) (cconst_int 4) dbg], dbg) in
1164 let v6 = Cop(Cload (Byte_unsigned, Mutable),
1165 [add_int (add_int ptr idx dbg) (cconst_int 5) dbg], dbg) in
1166 let v7 = Cop(Cload (Byte_unsigned, Mutable),
1167 [add_int (add_int ptr idx dbg) (cconst_int 6) dbg], dbg) in
1168 let v8 = Cop(Cload (Byte_unsigned, Mutable),
1169 [add_int (add_int ptr idx dbg) (cconst_int 7) dbg], dbg) in
1170 let b1, b2, b3, b4, b5, b6, b7, b8 =
1171 if Arch.big_endian
1172 then v1, v2, v3, v4, v5, v6, v7, v8
1173 else v8, v7, v6, v5, v4, v3, v2, v1 in
1174 Cop(Cor,
1175 [Cop(Cor,
1176 [Cop(Cor, [lsl_int b1 (cconst_int (8*7)) dbg;
1177 lsl_int b2 (cconst_int (8*6)) dbg], dbg);
1178 Cop(Cor, [lsl_int b3 (cconst_int (8*5)) dbg;
1179 lsl_int b4 (cconst_int (8*4)) dbg], dbg)],
1180 dbg);
1181 Cop(Cor,
1182 [Cop(Cor, [lsl_int b5 (cconst_int (8*3)) dbg;
1183 lsl_int b6 (cconst_int (8*2)) dbg], dbg);
1184 Cop(Cor, [lsl_int b7 (cconst_int 8) dbg;
1185 b8], dbg)],
1186 dbg)], dbg)
1187
1188 let unaligned_set_64 ptr idx newval dbg =
1189 assert(size_int = 8);
1190 if Arch.allow_unaligned_access
1191 then Cop(Cstore (Word_int, Assignment), [add_int ptr idx dbg; newval], dbg)
1192 else
1193 let cconst_int i = Cconst_int (i, dbg) in
1194 let v1 =
1195 Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*7)], dbg); cconst_int 0xFF],
1196 dbg)
1197 in
1198 let v2 =
1199 Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*6)], dbg); cconst_int 0xFF],
1200 dbg)
1201 in
1202 let v3 =
1203 Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*5)], dbg); cconst_int 0xFF],
1204 dbg)
1205 in
1206 let v4 =
1207 Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*4)], dbg); cconst_int 0xFF],
1208 dbg)
1209 in
1210 let v5 =
1211 Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*3)], dbg); cconst_int 0xFF],
1212 dbg)
1213 in
1214 let v6 =
1215 Cop(Cand, [Cop(Clsr, [newval; cconst_int (8*2)], dbg); cconst_int 0xFF],
1216 dbg)
1217 in
1218 let v7 =
1219 Cop(Cand, [Cop(Clsr, [newval; cconst_int 8], dbg); cconst_int 0xFF],
1220 dbg)
1221 in
1222 let v8 = Cop(Cand, [newval; cconst_int 0xFF], dbg) in
1223 let b1, b2, b3, b4, b5, b6, b7, b8 =
1224 if Arch.big_endian
1225 then v1, v2, v3, v4, v5, v6, v7, v8
1226 else v8, v7, v6, v5, v4, v3, v2, v1 in
1227 Csequence(
1228 Csequence(
1229 Csequence(
1230 Cop(Cstore (Byte_unsigned, Assignment),
1231 [add_int ptr idx dbg; b1],
1232 dbg),
1233 Cop(Cstore (Byte_unsigned, Assignment),
1234 [add_int (add_int ptr idx dbg) (cconst_int 1) dbg; b2],
1235 dbg)),
1236 Csequence(
1237 Cop(Cstore (Byte_unsigned, Assignment),
1238 [add_int (add_int ptr idx dbg) (cconst_int 2) dbg; b3],
1239 dbg),
1240 Cop(Cstore (Byte_unsigned, Assignment),
1241 [add_int (add_int ptr idx dbg) (cconst_int 3) dbg; b4],
1242 dbg))),
1243 Csequence(
1244 Csequence(
1245 Cop(Cstore (Byte_unsigned, Assignment),
1246 [add_int (add_int ptr idx dbg) (cconst_int 4) dbg; b5],
1247 dbg),
1248 Cop(Cstore (Byte_unsigned, Assignment),
1249 [add_int (add_int ptr idx dbg) (cconst_int 5) dbg; b6],
1250 dbg)),
1251 Csequence(
1252 Cop(Cstore (Byte_unsigned, Assignment),
1253 [add_int (add_int ptr idx dbg) (cconst_int 6) dbg; b7],
1254 dbg),
1255 Cop(Cstore (Byte_unsigned, Assignment),
1256 [add_int (add_int ptr idx dbg) (cconst_int 7) dbg; b8],
1257 dbg))))
1258
1259 let max_or_zero a dbg =
1260 bind "size" a (fun a ->
1261 (* equivalent to
1262 Cifthenelse(Cop(Ccmpi Cle, [a; cconst_int 0]), cconst_int 0, a)
1263
1264 if a is positive, sign is 0 hence sign_negation is full of 1
1265 so sign_negation&a = a
1266 if a is negative, sign is full of 1 hence sign_negation is 0
1267 so sign_negation&a = 0 *)
1268 let sign = Cop(Casr, [a; Cconst_int (size_int * 8 - 1, dbg)], dbg) in
1269 let sign_negation = Cop(Cxor, [sign; Cconst_int (-1, dbg)], dbg) in
1270 Cop(Cand, [sign_negation; a], dbg))
1271
1272 let check_bound safety access_size dbg length a2 k =
1273 match (safety : Lambda.is_safe) with
1274 | Unsafe -> k
1275 | Safe ->
1276 let offset =
1277 match (access_size : Clambda_primitives.memory_access_size) with
1278 | Sixteen -> 1
1279 | Thirty_two -> 3
1280 | Sixty_four -> 7
1281 in
1282 let a1 =
1283 sub_int length (Cconst_int (offset, dbg)) dbg
1284 in
1285 Csequence(make_checkbound dbg [max_or_zero a1 dbg; a2], k)
1286
1287 let unaligned_set size ptr idx newval dbg =
1288 match (size : Clambda_primitives.memory_access_size) with
1289 | Sixteen -> unaligned_set_16 ptr idx newval dbg
1290 | Thirty_two -> unaligned_set_32 ptr idx newval dbg
1291 | Sixty_four -> unaligned_set_64 ptr idx newval dbg
1292
1293 let unaligned_load size ptr idx dbg =
1294 match (size : Clambda_primitives.memory_access_size) with
1295 | Sixteen -> unaligned_load_16 ptr idx dbg
1296 | Thirty_two -> unaligned_load_32 ptr idx dbg
1297 | Sixty_four -> unaligned_load_64 ptr idx dbg
1298
1299 let box_sized size dbg exp =
1300 match (size : Clambda_primitives.memory_access_size) with
1301 | Sixteen -> tag_int exp dbg
1302 | Thirty_two -> box_int_gen dbg Pint32 exp
1303 | Sixty_four -> box_int_gen dbg Pint64 exp
1304
1305 (* Simplification of some primitives into C calls *)
1306
1307 let default_prim name =
1308 Primitive.simple ~name ~arity:0(*ignored*) ~alloc:true
1309
1310
1311 let int64_native_prim name arity ~alloc =
1312 let u64 = Primitive.Unboxed_integer Primitive.Pint64 in
1313 let rec make_args = function 0 -> [] | n -> u64 :: make_args (n - 1) in
1314 Primitive.make ~name ~native_name:(name ^ "_native")
1315 ~alloc
1316 ~native_repr_args:(make_args arity)
1317 ~native_repr_res:u64
1318
1319 let simplif_primitive_32bits :
1320 Clambda_primitives.primitive -> Clambda_primitives.primitive = function
1321 Pbintofint Pint64 -> Pccall (default_prim "caml_int64_of_int")
1322 | Pintofbint Pint64 -> Pccall (default_prim "caml_int64_to_int")
1323 | Pcvtbint(Pint32, Pint64) -> Pccall (default_prim "caml_int64_of_int32")
1324 | Pcvtbint(Pint64, Pint32) -> Pccall (default_prim "caml_int64_to_int32")
1325 | Pcvtbint(Pnativeint, Pint64) ->
1326 Pccall (default_prim "caml_int64_of_nativeint")
1327 | Pcvtbint(Pint64, Pnativeint) ->
1328 Pccall (default_prim "caml_int64_to_nativeint")
1329 | Pnegbint Pint64 -> Pccall (int64_native_prim "caml_int64_neg" 1
1330 ~alloc:false)
1331 | Paddbint Pint64 -> Pccall (int64_native_prim "caml_int64_add" 2
1332 ~alloc:false)
1333 | Psubbint Pint64 -> Pccall (int64_native_prim "caml_int64_sub" 2
1334 ~alloc:false)
1335 | Pmulbint Pint64 -> Pccall (int64_native_prim "caml_int64_mul" 2
1336 ~alloc:false)
1337 | Pdivbint {size=Pint64} -> Pccall (int64_native_prim "caml_int64_div" 2
1338 ~alloc:true)
1339 | Pmodbint {size=Pint64} -> Pccall (int64_native_prim "caml_int64_mod" 2
1340 ~alloc:true)
1341 | Pandbint Pint64 -> Pccall (int64_native_prim "caml_int64_and" 2
1342 ~alloc:false)
1343 | Porbint Pint64 -> Pccall (int64_native_prim "caml_int64_or" 2
1344 ~alloc:false)
1345 | Pxorbint Pint64 -> Pccall (int64_native_prim "caml_int64_xor" 2
1346 ~alloc:false)
1347 | Plslbint Pint64 -> Pccall (default_prim "caml_int64_shift_left")
1348 | Plsrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right_unsigned")
1349 | Pasrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right")
1350 | Pbintcomp(Pint64, Lambda.Ceq) -> Pccall (default_prim "caml_equal")
1351 | Pbintcomp(Pint64, Lambda.Cne) -> Pccall (default_prim "caml_notequal")
1352 | Pbintcomp(Pint64, Lambda.Clt) -> Pccall (default_prim "caml_lessthan")
1353 | Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "caml_greaterthan")
1354 | Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal")
1355 | Pbintcomp(Pint64, Lambda.Cge) -> Pccall (default_prim "caml_greaterequal")
1356 | Pbigarrayref(_unsafe, n, Pbigarray_int64, _layout) ->
1357 Pccall (default_prim ("caml_ba_get_" ^ Int.to_string n))
1358 | Pbigarrayset(_unsafe, n, Pbigarray_int64, _layout) ->
1359 Pccall (default_prim ("caml_ba_set_" ^ Int.to_string n))
1360 | Pstring_load(Sixty_four, _) -> Pccall (default_prim "caml_string_get64")
1361 | Pbytes_load(Sixty_four, _) -> Pccall (default_prim "caml_bytes_get64")
1362 | Pbytes_set(Sixty_four, _) -> Pccall (default_prim "caml_bytes_set64")
1363 | Pbigstring_load(Sixty_four,_) -> Pccall (default_prim "caml_ba_uint8_get64")
1364 | Pbigstring_set(Sixty_four,_) -> Pccall (default_prim "caml_ba_uint8_set64")
1365 | Pbbswap Pint64 -> Pccall (default_prim "caml_int64_bswap")
1366 | p -> p
1367
1368 let simplif_primitive p : Clambda_primitives.primitive =
1369 match (p : Clambda_primitives.primitive) with
1370 | Pduprecord _ ->
1371 Pccall (default_prim "caml_obj_dup")
1372 | Pbigarrayref(_unsafe, n, Pbigarray_unknown, _layout) ->
1373 Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
1374 | Pbigarrayset(_unsafe, n, Pbigarray_unknown, _layout) ->
1375 Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
1376 | Pbigarrayref(_unsafe, n, _kind, Pbigarray_unknown_layout) ->
1377 Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
1378 | Pbigarrayset(_unsafe, n, _kind, Pbigarray_unknown_layout) ->
1379 Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
1380 | p ->
1381 if size_int = 8 then p else simplif_primitive_32bits p
1382
1383 (* Build switchers both for constants and blocks *)
1384
1385 let transl_isout h arg dbg = tag_int (Cop(Ccmpa Clt, [h ; arg], dbg)) dbg
1386
1387 (* Build an actual switch (ie jump table) *)
1388
1389 let make_switch arg cases actions dbg =
1390 let extract_uconstant =
1391 function
1392 (* Constant integers loaded from a table should end in 1,
1393 so that Cload never produces untagged integers *)
1394 | Cconst_int (n, _), _dbg
1395 | Cconst_pointer (n, _), _dbg when (n land 1) = 1 ->
1396 Some (Cint (Nativeint.of_int n))
1397 | Cconst_natint (n, _), _dbg
1398 | Cconst_natpointer (n, _), _dbg
1399 when Nativeint.(to_int (logand n one) = 1) ->
1400 Some (Cint n)
1401 | Cconst_symbol (s,_), _dbg ->
1402 Some (Csymbol_address s)
1403 | _ -> None
1404 in
1405 let extract_affine ~cases ~const_actions =
1406 let length = Array.length cases in
1407 if length >= 2
1408 then begin
1409 match const_actions.(cases.(0)), const_actions.(cases.(1)) with
1410 | Cint v0, Cint v1 ->
1411 let slope = Nativeint.sub v1 v0 in
1412 let check i = function
1413 | Cint v -> v = Nativeint.(add (mul (of_int i) slope) v0)
1414 | _ -> false
1415 in
1416 if Misc.Stdlib.Array.for_alli
1417 (fun i idx -> check i const_actions.(idx)) cases
1418 then Some (v0, slope)
1419 else None
1420 | _, _ ->
1421 None
1422 end
1423 else None
1424 in
1425 let make_table_lookup ~cases ~const_actions arg dbg =
1426 let table = Compilenv.new_const_symbol () in
1427 Cmmgen_state.add_constant table (Const_table (Local,
1428 Array.to_list (Array.map (fun act ->
1429 const_actions.(act)) cases)));
1430 addr_array_ref (Cconst_symbol (table, dbg)) (tag_int arg dbg) dbg
1431 in
1432 let make_affine_computation ~offset ~slope arg dbg =
1433 (* In case the resulting integers are an affine function of the index, we
1434 don't emit a table, and just compute the result directly *)
1435 add_int
1436 (mul_int arg (natint_const_untagged dbg slope) dbg)
1437 (natint_const_untagged dbg offset)
1438 dbg
1439 in
1440 match Misc.Stdlib.Array.all_somes (Array.map extract_uconstant actions) with
1441 | None ->
1442 Cswitch (arg,cases,actions,dbg)
1443 | Some const_actions ->
1444 match extract_affine ~cases ~const_actions with
1445 | Some (offset, slope) ->
1446 make_affine_computation ~offset ~slope arg dbg
1447 | None -> make_table_lookup ~cases ~const_actions arg dbg
1448
1449 module SArgBlocks =
1450 struct
1451 type primitive = operation
1452
1453 let eqint = Ccmpi Ceq
1454 let neint = Ccmpi Cne
1455 let leint = Ccmpi Cle
1456 let ltint = Ccmpi Clt
1457 let geint = Ccmpi Cge
1458 let gtint = Ccmpi Cgt
1459
1460 type act = expression
1461
1462 (* CR mshinwell: GPR#2294 will fix the Debuginfo here *)
1463
1464 let make_const i = Cconst_int (i, Debuginfo.none)
1465 let make_prim p args = Cop (p,args, Debuginfo.none)
1466 let make_offset arg n = add_const arg n Debuginfo.none
1467 let make_isout h arg = Cop (Ccmpa Clt, [h ; arg], Debuginfo.none)
1468 let make_isin h arg = Cop (Ccmpa Cge, [h ; arg], Debuginfo.none)
1469 let make_if cond ifso ifnot =
1470 Cifthenelse (cond, Debuginfo.none, ifso, Debuginfo.none, ifnot,
1471 Debuginfo.none)
1472 let make_switch loc arg cases actions =
1473 let dbg = Debuginfo.from_location loc in
1474 let actions = Array.map (fun expr -> expr, dbg) actions in
1475 make_switch arg cases actions dbg
1476 let bind arg body = bind "switcher" arg body
1477
1478 let make_catch handler = match handler with
1479 | Cexit (i,[]) -> i,fun e -> e
1480 | _ ->
1481 let dbg = Debuginfo.none in
1482 let i = Lambda.next_raise_count () in
1483 (*
1484 Printf.eprintf "SHARE CMM: %i\n" i ;
1485 Printcmm.expression Format.str_formatter handler ;
1486 Printf.eprintf "%s\n" (Format.flush_str_formatter ()) ;
1487 *)
1488 i,
1489 (fun body -> match body with
1490 | Cexit (j,_) ->
1491 if i=j then handler
1492 else body
1493 | _ -> ccatch (i,[],body,handler, dbg))
1494
1495 let make_exit i = Cexit (i,[])
1496
1497 end
1498
1499 (* cmm store, as sharing as normally been detected in previous
1500 phases, we only share exits *)
1501 (* Some specific patterns can lead to switches where several cases
1502 point to the same action, but this action is not an exit (see GPR#1370).
1503 The addition of the index in the action array as context allows to
1504 share them correctly without duplication. *)
1505 module StoreExpForSwitch =
1506 Switch.CtxStore
1507 (struct
1508 type t = expression
1509 type key = int option * int
1510 type context = int
1511 let make_key index expr =
1512 let continuation =
1513 match expr with
1514 | Cexit (i,[]) -> Some i
1515 | _ -> None
1516 in
1517 Some (continuation, index)
1518 let compare_key (cont, index) (cont', index') =
1519 match cont, cont' with
1520 | Some i, Some i' when i = i' -> 0
1521 | _, _ -> Stdlib.compare index index'
1522 end)
1523
1524 (* For string switches, we can use a generic store *)
1525 module StoreExp =
1526 Switch.Store
1527 (struct
1528 type t = expression
1529 type key = int
1530 let make_key = function
1531 | Cexit (i,[]) -> Some i
1532 | _ -> None
1533 let compare_key = Stdlib.compare
1534 end)
1535
1536 module SwitcherBlocks = Switch.Make(SArgBlocks)
1537
1538 (* Int switcher, arg in [low..high],
1539 cases is list of individual cases, and is sorted by first component *)
1540
1541 let transl_int_switch loc arg low high cases default = match cases with
1542 | [] -> assert false
1543 | _::_ ->
1544 let store = StoreExp.mk_store () in
1545 assert (store.Switch.act_store () default = 0) ;
1546 let cases =
1547 List.map
1548 (fun (i,act) -> i,store.Switch.act_store () act)
1549 cases in
1550 let rec inters plow phigh pact = function
1551 | [] ->
1552 if phigh = high then [plow,phigh,pact]
1553 else [(plow,phigh,pact); (phigh+1,high,0) ]
1554 | (i,act)::rem ->
1555 if i = phigh+1 then
1556 if pact = act then
1557 inters plow i pact rem
1558 else
1559 (plow,phigh,pact)::inters i i act rem
1560 else (* insert default *)
1561 if pact = 0 then
1562 if act = 0 then
1563 inters plow i 0 rem
1564 else
1565 (plow,i-1,pact)::
1566 inters i i act rem
1567 else (* pact <> 0 *)
1568 (plow,phigh,pact)::
1569 begin
1570 if act = 0 then inters (phigh+1) i 0 rem
1571 else (phigh+1,i-1,0)::inters i i act rem
1572 end in
1573 let inters = match cases with
1574 | [] -> assert false
1575 | (k0,act0)::rem ->
1576 if k0 = low then inters k0 k0 act0 rem
1577 else inters low (k0-1) 0 cases in
1578 bind "switcher" arg
1579 (fun a ->
1580 SwitcherBlocks.zyva
1581 loc
1582 (low,high)
1583 a
1584 (Array.of_list inters) store)
1585
1586
1587 let transl_switch_clambda loc arg index cases =
1588 let store = StoreExpForSwitch.mk_store () in
1589 let index =
1590 Array.map
1591 (fun j -> store.Switch.act_store j cases.(j))
1592 index in
1593 let n_index = Array.length index in
1594 let inters = ref []
1595 and this_high = ref (n_index-1)
1596 and this_low = ref (n_index-1)
1597 and this_act = ref index.(n_index-1) in
1598 for i = n_index-2 downto 0 do
1599 let act = index.(i) in
1600 if act = !this_act then
1601 decr this_low
1602 else begin
1603 inters := (!this_low, !this_high, !this_act) :: !inters ;
1604 this_high := i ;
1605 this_low := i ;
1606 this_act := act
1607 end
1608 done ;
1609 inters := (0, !this_high, !this_act) :: !inters ;
1610 match !inters with
1611 | [_] -> cases.(0)
1612 | inters ->
1613 bind "switcher" arg
1614 (fun a ->
1615 SwitcherBlocks.zyva
1616 loc
1617 (0,n_index-1)
1618 a
1619 (Array.of_list inters) store)
1620
1621 let strmatch_compile =
1622 let module S =
1623 Strmatch.Make
1624 (struct
1625 let string_block_length ptr = get_size ptr Debuginfo.none
1626 let transl_switch = transl_int_switch
1627 end) in
1628 S.compile
1629
1630 let ptr_offset ptr offset dbg =
1631 if offset = 0
1632 then ptr
1633 else Cop(Caddv, [ptr; Cconst_int(offset * size_addr, dbg)], dbg)
1634
1635 let direct_apply lbl args dbg =
1636 Cop(Capply typ_val, Cconst_symbol (lbl, dbg) :: args, dbg)
1637
1638 let generic_apply mut clos args dbg =
1639 match args with
1640 | [arg] ->
1641 bind "fun" clos (fun clos ->
1642 Cop(Capply typ_val, [get_field_gen mut clos 0 dbg; arg; clos],
1643 dbg))
1644 | _ ->
1645 let arity = List.length args in
1646 let cargs =
1647 Cconst_symbol(apply_function_sym arity, dbg) :: args @ [clos]
1648 in
1649 Cop(Capply typ_val, cargs, dbg)
1650
1651 let send kind met obj args dbg =
1652 let call_met obj args clos =
1653 (* met is never a simple expression, so it never gets turned into an
1654 Immutable load *)
1655 generic_apply Asttypes.Mutable clos (obj :: args) dbg
1656 in
1657 bind "obj" obj (fun obj ->
1658 match (kind : Lambda.meth_kind), args with
1659 Self, _ ->
1660 bind "met" (lookup_label obj met dbg)
1661 (call_met obj args)
1662 | Cached, cache :: pos :: args ->
1663 call_cached_method obj met cache pos args dbg
1664 | _ ->
1665 bind "met" (lookup_tag obj met dbg)
1666 (call_met obj args))
1667
1668 (*
1669 CAMLprim value caml_cache_public_method (value meths, value tag, value *cache)
1670 {
1671 int li = 3, hi = Field(meths,0), mi;
1672 while (li < hi) { // no need to check the 1st time
1673 mi = ((li+hi) >> 1) | 1;
1674 if (tag < Field(meths,mi)) hi = mi-2;
1675 else li = mi;
1676 }
1677 *cache = (li-3)*sizeof(value)+1;
1678 return Field (meths, li-1);
1679 }
1680 *)
1681
1682 let cache_public_method meths tag cache dbg =
1683 let raise_num = Lambda.next_raise_count () in
1684 let cconst_int i = Cconst_int (i, dbg) in
1685 let li = V.create_local "*li*" and hi = V.create_local "*hi*"
1686 and mi = V.create_local "*mi*" and tagged = V.create_local "*tagged*" in
1687 Clet (
1688 VP.create li, cconst_int 3,
1689 Clet (
1690 VP.create hi, Cop(Cload (Word_int, Mutable), [meths], dbg),
1691 Csequence(
1692 ccatch
1693 (raise_num, [],
1694 create_loop
1695 (Clet(
1696 VP.create mi,
1697 Cop(Cor,
1698 [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi], dbg); cconst_int 1],
1699 dbg);
1700 cconst_int 1],
1701 dbg),
1702 Csequence(
1703 Cifthenelse
1704 (Cop (Ccmpi Clt,
1705 [tag;
1706 Cop(Cload (Word_int, Mutable),
1707 [Cop(Cadda,
1708 [meths; lsl_const (Cvar mi) log2_size_addr dbg],
1709 dbg)],
1710 dbg)], dbg),
1711 dbg, Cassign(hi, Cop(Csubi, [Cvar mi; cconst_int 2], dbg)),
1712 dbg, Cassign(li, Cvar mi),
1713 dbg),
1714 Cifthenelse
1715 (Cop(Ccmpi Cge, [Cvar li; Cvar hi], dbg),
1716 dbg, Cexit (raise_num, []),
1717 dbg, Ctuple [],
1718 dbg))))
1719 dbg,
1720 Ctuple [],
1721 dbg),
1722 Clet (
1723 VP.create tagged,
1724 Cop(Cadda, [lsl_const (Cvar li) log2_size_addr dbg;
1725 cconst_int(1 - 3 * size_addr)], dbg),
1726 Csequence(Cop (Cstore (Word_int, Assignment), [cache; Cvar tagged], dbg),
1727 Cvar tagged)))))
1728
1729 (* CR mshinwell: These will be filled in by later pull requests. *)
1730 let placeholder_dbg () = Debuginfo.none
1731 let placeholder_fun_dbg ~human_name:_ = Debuginfo.none
1732
1733 (* Generate an application function:
1734 (defun caml_applyN (a1 ... aN clos)
1735 (if (= clos.arity N)
1736 (app clos.direct a1 ... aN clos)
1737 (let (clos1 (app clos.code a1 clos)
1738 clos2 (app clos1.code a2 clos)
1739 ...
1740 closN-1 (app closN-2.code aN-1 closN-2))
1741 (app closN-1.code aN closN-1))))
1742 *)
1743
1744 let apply_function_body arity =
1745 let dbg = placeholder_dbg in
1746 let arg = Array.make arity (V.create_local "arg") in
1747 for i = 1 to arity - 1 do arg.(i) <- V.create_local "arg" done;
1748 let clos = V.create_local "clos" in
1749 let rec app_fun clos n =
1750 if n = arity-1 then
1751 Cop(Capply typ_val,
1752 [get_field_gen Asttypes.Mutable (Cvar clos) 0 (dbg ());
1753 Cvar arg.(n);
1754 Cvar clos],
1755 dbg ())
1756 else begin
1757 let newclos = V.create_local "clos" in
1758 Clet(VP.create newclos,
1759 Cop(Capply typ_val,
1760 [get_field_gen Asttypes.Mutable (Cvar clos) 0 (dbg ());
1761 Cvar arg.(n); Cvar clos], dbg ()),
1762 app_fun newclos (n+1))
1763 end in
1764 let args = Array.to_list arg in
1765 let all_args = args @ [clos] in
1766 (args, clos,
1767 if arity = 1 then app_fun clos 0 else
1768 Cifthenelse(
1769 Cop(Ccmpi Ceq, [get_field_gen Asttypes.Mutable (Cvar clos) 1 (dbg ());
1770 int_const (dbg ()) arity], dbg ()),
1771 dbg (),
1772 Cop(Capply typ_val,
1773 get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ())
1774 :: List.map (fun s -> Cvar s) all_args,
1775 dbg ()),
1776 dbg (),
1777 app_fun clos 0,
1778 dbg ()))
1779
1780 let send_function arity =
1781 let dbg = placeholder_dbg in
1782 let cconst_int i = Cconst_int (i, dbg ()) in
1783 let (args, clos', body) = apply_function_body (1+arity) in
1784 let cache = V.create_local "cache"
1785 and obj = List.hd args
1786 and tag = V.create_local "tag" in
1787 let clos =
1788 let cache = Cvar cache and obj = Cvar obj and tag = Cvar tag in
1789 let meths = V.create_local "meths" and cached = V.create_local "cached" in
1790 let real = V.create_local "real" in
1791 let mask = get_field_gen Asttypes.Mutable (Cvar meths) 1 (dbg ()) in
1792 let cached_pos = Cvar cached in
1793 let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths], dbg ());
1794 cconst_int(3*size_addr-1)], dbg ()) in
1795 let tag' = Cop(Cload (Word_int, Mutable), [tag_pos], dbg ()) in
1796 Clet (
1797 VP.create meths, Cop(Cload (Word_val, Mutable), [obj], dbg ()),
1798 Clet (
1799 VP.create cached,
1800 Cop(Cand, [Cop(Cload (Word_int, Mutable), [cache], dbg ()); mask],
1801 dbg ()),
1802 Clet (
1803 VP.create real,
1804 Cifthenelse(Cop(Ccmpa Cne, [tag'; tag], dbg ()),
1805 dbg (),
1806 cache_public_method (Cvar meths) tag cache (dbg ()),
1807 dbg (),
1808 cached_pos,
1809 dbg ()),
1810 Cop(Cload (Word_val, Mutable),
1811 [Cop(Cadda, [Cop (Cadda, [Cvar real; Cvar meths], dbg ());
1812 cconst_int(2*size_addr-1)], dbg ())], dbg ()))))
1813
1814 in
1815 let body = Clet(VP.create clos', clos, body) in
1816 let cache = cache in
1817 let fun_name = "caml_send" ^ Int.to_string arity in
1818 let fun_args =
1819 [obj, typ_val; tag, typ_int; cache, typ_val]
1820 @ List.map (fun id -> (id, typ_val)) (List.tl args) in
1821 let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in
1822 Cfunction
1823 {fun_name;
1824 fun_args = List.map (fun (arg, ty) -> VP.create arg, ty) fun_args;
1825 fun_body = body;
1826 fun_codegen_options = [];
1827 fun_dbg;
1828 }
1829
1830 let apply_function arity =
1831 let (args, clos, body) = apply_function_body arity in
1832 let all_args = args @ [clos] in
1833 let fun_name = "caml_apply" ^ Int.to_string arity in
1834 let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in
1835 Cfunction
1836 {fun_name;
1837 fun_args = List.map (fun arg -> (VP.create arg, typ_val)) all_args;
1838 fun_body = body;
1839 fun_codegen_options = [];
1840 fun_dbg;
1841 }
1842
1843 (* Generate tuplifying functions:
1844 (defun caml_tuplifyN (arg clos)
1845 (app clos.direct #0(arg) ... #N-1(arg) clos)) *)
1846
1847 let tuplify_function arity =
1848 let dbg = placeholder_dbg in
1849 let arg = V.create_local "arg" in
1850 let clos = V.create_local "clos" in
1851 let rec access_components i =
1852 if i >= arity
1853 then []
1854 else get_field_gen Asttypes.Mutable (Cvar arg) i (dbg ())
1855 :: access_components(i+1)
1856 in
1857 let fun_name = "caml_tuplify" ^ Int.to_string arity in
1858 let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in
1859 Cfunction
1860 {fun_name;
1861 fun_args = [VP.create arg, typ_val; VP.create clos, typ_val];
1862 fun_body =
1863 Cop(Capply typ_val,
1864 get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ())
1865 :: access_components 0 @ [Cvar clos],
1866 (dbg ()));
1867 fun_codegen_options = [];
1868 fun_dbg;
1869 }
1870
1871 (* Generate currying functions:
1872 (defun caml_curryN (arg clos)
1873 (alloc HDR caml_curryN_1 <arity (N-1)> caml_curry_N_1_app arg clos))
1874 (defun caml_curryN_1 (arg clos)
1875 (alloc HDR caml_curryN_2 <arity (N-2)> caml_curry_N_2_app arg clos))
1876 ...
1877 (defun caml_curryN_N-1 (arg clos)
1878 (let (closN-2 clos.vars[1]
1879 closN-3 closN-2.vars[1]
1880 ...
1881 clos1 clos2.vars[1]
1882 clos clos1.vars[1])
1883 (app clos.direct
1884 clos1.vars[0] ... closN-2.vars[0] clos.vars[0] arg clos)))
1885
1886 Special "shortcut" functions are also generated to handle the
1887 case where a partially applied function is applied to all remaining
1888 arguments in one go. For instance:
1889 (defun caml_curry_N_1_app (arg2 ... argN clos)
1890 (let clos' clos.vars[1]
1891 (app clos'.direct clos.vars[0] arg2 ... argN clos')))
1892
1893 Those shortcuts may lead to a quadratic number of application
1894 primitives being generated in the worst case, which resulted in
1895 linking time blowup in practice (PR#5933), so we only generate and
1896 use them when below a fixed arity 'max_arity_optimized'.
1897 *)
1898
1899 let max_arity_optimized = 15
1900 let final_curry_function arity =
1901 let dbg = placeholder_dbg in
1902 let last_arg = V.create_local "arg" in
1903 let last_clos = V.create_local "clos" in
1904 let rec curry_fun args clos n =
1905 if n = 0 then
1906 Cop(Capply typ_val,
1907 get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ()) ::
1908 args @ [Cvar last_arg; Cvar clos],
1909 dbg ())
1910 else
1911 if n = arity - 1 || arity > max_arity_optimized then
1912 begin
1913 let newclos = V.create_local "clos" in
1914 Clet(VP.create newclos,
1915 get_field_gen Asttypes.Mutable (Cvar clos) 3 (dbg ()),
1916 curry_fun (get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ())
1917 :: args)
1918 newclos (n-1))
1919 end else
1920 begin
1921 let newclos = V.create_local "clos" in
1922 Clet(VP.create newclos,
1923 get_field_gen Asttypes.Mutable (Cvar clos) 4 (dbg ()),
1924 curry_fun
1925 (get_field_gen Asttypes.Mutable (Cvar clos) 3 (dbg ()) :: args)
1926 newclos (n-1))
1927 end in
1928 let fun_name =
1929 "caml_curry" ^ Int.to_string arity ^ "_" ^ Int.to_string (arity-1)
1930 in
1931 let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in
1932 Cfunction
1933 {fun_name;
1934 fun_args = [VP.create last_arg, typ_val; VP.create last_clos, typ_val];
1935 fun_body = curry_fun [] last_clos (arity-1);
1936 fun_codegen_options = [];
1937 fun_dbg;
1938 }
1939
1940 let rec intermediate_curry_functions arity num =
1941 let dbg = placeholder_dbg in
1942 if num = arity - 1 then
1943 [final_curry_function arity]
1944 else begin
1945 let name1 = "caml_curry" ^ Int.to_string arity in
1946 let name2 = if num = 0 then name1 else name1 ^ "_" ^ Int.to_string num in
1947 let arg = V.create_local "arg" and clos = V.create_local "clos" in
1948 let fun_dbg = placeholder_fun_dbg ~human_name:name2 in
1949 Cfunction
1950 {fun_name = name2;
1951 fun_args = [VP.create arg, typ_val; VP.create clos, typ_val];
1952 fun_body =
1953 if arity - num > 2 && arity <= max_arity_optimized then
1954 Cop(Calloc,
1955 [alloc_closure_header 5 (dbg ());
1956 Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1), dbg ());
1957 int_const (dbg ()) (arity - num - 1);
1958 Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1) ^ "_app",
1959 dbg ());
1960 Cvar arg; Cvar clos],
1961 dbg ())
1962 else
1963 Cop(Calloc,
1964 [alloc_closure_header 4 (dbg ());
1965 Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1), dbg ());
1966 int_const (dbg ()) 1; Cvar arg; Cvar clos],
1967 dbg ());
1968 fun_codegen_options = [];
1969 fun_dbg;
1970 }
1971 ::
1972 (if arity <= max_arity_optimized && arity - num > 2 then
1973 let rec iter i =
1974 if i <= arity then
1975 let arg = V.create_local (Printf.sprintf "arg%d" i) in
1976 (arg, typ_val) :: iter (i+1)
1977 else []
1978 in
1979 let direct_args = iter (num+2) in
1980 let rec iter i args clos =
1981 if i = 0 then
1982 Cop(Capply typ_val,
1983 (get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ()))
1984 :: args @ [Cvar clos],
1985 dbg ())
1986 else
1987 let newclos = V.create_local "clos" in
1988 Clet(VP.create newclos,
1989 get_field_gen Asttypes.Mutable (Cvar clos) 4 (dbg ()),
1990 iter (i-1)
1991 (get_field_gen Asttypes.Mutable (Cvar clos) 3 (dbg ())
1992 :: args)
1993 newclos)
1994 in
1995 let fun_args =
1996 List.map (fun (arg, ty) -> VP.create arg, ty)
1997 (direct_args @ [clos, typ_val])
1998 in
1999 let fun_name = name1 ^ "_" ^ Int.to_string (num+1) ^ "_app" in
2000 let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in
2001 let cf =
2002 Cfunction
2003 {fun_name;
2004 fun_args;
2005 fun_body = iter (num+1)
2006 (List.map (fun (arg,_) -> Cvar arg) direct_args) clos;
2007 fun_codegen_options = [];
2008 fun_dbg;
2009 }
2010 in
2011 cf :: intermediate_curry_functions arity (num+1)
2012 else
2013 intermediate_curry_functions arity (num+1))
2014 end
2015
2016 let curry_function arity =
2017 assert(arity <> 0);
2018 (* Functions with arity = 0 does not have a curry_function *)
2019 if arity > 0
2020 then intermediate_curry_functions arity 0
2021 else [tuplify_function (-arity)]
2022
2023 module Int = Numbers.Int
2024
2025 let default_apply = Int.Set.add 2 (Int.Set.add 3 Int.Set.empty)
2026 (* These apply funs are always present in the main program because
2027 the run-time system needs them (cf. runtime/<arch>.S) . *)
2028
2029 let generic_functions shared units =
2030 let (apply,send,curry) =
2031 List.fold_left
2032 (fun (apply,send,curry) (ui : Cmx_format.unit_infos) ->
2033 List.fold_right Int.Set.add ui.ui_apply_fun apply,
2034 List.fold_right Int.Set.add ui.ui_send_fun send,
2035 List.fold_right Int.Set.add ui.ui_curry_fun curry)
2036 (Int.Set.empty,Int.Set.empty,Int.Set.empty)
2037 units in
2038 let apply = if shared then apply else Int.Set.union apply default_apply in
2039 let accu = Int.Set.fold (fun n accu -> apply_function n :: accu) apply [] in
2040 let accu = Int.Set.fold (fun n accu -> send_function n :: accu) send accu in
2041 Int.Set.fold (fun n accu -> curry_function n @ accu) curry accu
2042
2043 (* Primitives *)
2044
2045 type unary_primitive = expression -> Debuginfo.t -> expression
2046
2047 let floatfield n ptr dbg =
2048 Cop(Cload (Double_u, Mutable),
2049 [if n = 0 then ptr
2050 else Cop(Cadda, [ptr; Cconst_int(n * size_float, dbg)], dbg)],
2051 dbg)
2052
2053 let int_as_pointer arg dbg =
2054 Cop(Caddi, [arg; Cconst_int (-1, dbg)], dbg)
2055 (* always a pointer outside the heap *)
2056
2057 let raise_prim raise_kind arg dbg =
2058 if !Clflags.debug then
2059 Cop (Craise raise_kind, [arg], dbg)
2060 else
2061 Cop (Craise Lambda.Raise_notrace, [arg], dbg)
2062
2063 let negint arg dbg =
2064 Cop(Csubi, [Cconst_int (2, dbg); arg], dbg)
2065
2066 (* [offsetint] moved down to reuse add_int_caml *)
2067
2068 let offsetref n arg dbg =
2069 return_unit dbg
2070 (bind "ref" arg (fun arg ->
2071 Cop(Cstore (Word_int, Assignment),
2072 [arg;
2073 add_const (Cop(Cload (Word_int, Mutable), [arg], dbg))
2074 (n lsl 1) dbg],
2075 dbg)))
2076
2077 let arraylength kind arg dbg =
2078 let hdr = get_header_without_profinfo arg dbg in
2079 match (kind : Lambda.array_kind) with
2080 Pgenarray ->
2081 let len =
2082 if wordsize_shift = numfloat_shift then
2083 Cop(Clsr, [hdr; Cconst_int (wordsize_shift, dbg)], dbg)
2084 else
2085 bind "header" hdr (fun hdr ->
2086 Cifthenelse(is_addr_array_hdr hdr dbg,
2087 dbg,
2088 Cop(Clsr,
2089 [hdr; Cconst_int (wordsize_shift, dbg)], dbg),
2090 dbg,
2091 Cop(Clsr,
2092 [hdr; Cconst_int (numfloat_shift, dbg)], dbg),
2093 dbg))
2094 in
2095 Cop(Cor, [len; Cconst_int (1, dbg)], dbg)
2096 | Paddrarray | Pintarray ->
2097 Cop(Cor, [addr_array_length_shifted hdr dbg; Cconst_int (1, dbg)], dbg)
2098 | Pfloatarray ->
2099 Cop(Cor, [float_array_length_shifted hdr dbg; Cconst_int (1, dbg)], dbg)
2100
2101 let bbswap bi arg dbg =
2102 let prim = match (bi : Primitive.boxed_integer) with
2103 | Pnativeint -> "nativeint"
2104 | Pint32 -> "int32"
2105 | Pint64 -> "int64"
2106 in
2107 Cop(Cextcall(Printf.sprintf "caml_%s_direct_bswap" prim,
2108 typ_int, false, None),
2109 [arg],
2110 dbg)
2111
2112 let bswap16 arg dbg =
2113 (Cop(Cextcall("caml_bswap16_direct", typ_int, false, None),
2114 [arg],
2115 dbg))
2116
2117 type binary_primitive = expression -> expression -> Debuginfo.t -> expression
2118
2119 (* let pfield_computed = addr_array_ref *)
2120
2121 (* Helper for compilation of initialization and assignment operations *)
2122
2123 type assignment_kind = Caml_modify | Caml_initialize | Simple
2124
2125 let assignment_kind
2126 (ptr: Lambda.immediate_or_pointer)
2127 (init: Lambda.initialization_or_assignment) =
2128 match init, ptr with
2129 | Assignment, Pointer -> Caml_modify
2130 | Heap_initialization, Pointer -> Caml_initialize
2131 | Assignment, Immediate
2132 | Heap_initialization, Immediate
2133 | Root_initialization, (Immediate | Pointer) -> Simple
2134
2135 let setfield n ptr init arg1 arg2 dbg =
2136 match assignment_kind ptr init with
2137 | Caml_modify ->
2138 return_unit dbg (Cop(Cextcall("caml_modify", typ_void, false, None),
2139 [field_address arg1 n dbg;
2140 arg2],
2141 dbg))
2142 | Caml_initialize ->
2143 return_unit dbg (Cop(Cextcall("caml_initialize", typ_void, false, None),
2144 [field_address arg1 n dbg;
2145 arg2],
2146 dbg))
2147 | Simple ->
2148 return_unit dbg (set_field arg1 n arg2 init dbg)
2149
2150 let setfloatfield n init arg1 arg2 dbg =
2151 return_unit dbg (
2152 Cop(Cstore (Double_u, init),
2153 [if n = 0 then arg1
2154 else Cop(Cadda, [arg1; Cconst_int(n * size_float, dbg)], dbg);
2155 arg2], dbg))
2156
2157 let add_int_caml arg1 arg2 dbg =
2158 decr_int (add_int arg1 arg2 dbg) dbg
2159
2160 (* Unary primitive delayed to reuse add_int_caml *)
2161 let offsetint n arg dbg =
2162 if Misc.no_overflow_lsl n 1 then
2163 add_const arg (n lsl 1) dbg
2164 else
2165 add_int_caml arg (int_const dbg n) dbg
2166
2167 let sub_int_caml arg1 arg2 dbg =
2168 incr_int (sub_int arg1 arg2 dbg) dbg
2169
2170 let mul_int_caml arg1 arg2 dbg =
2171 (* decrementing the non-constant part helps when the multiplication is
2172 followed by an addition;
2173 for example, using this trick compiles (100 * a + 7) into
2174 (+ ( * a 100) -85)
2175 rather than
2176 (+ ( * 200 (>>s a 1)) 15)
2177 *)
2178 match arg1, arg2 with
2179 | Cconst_int _ as c1, c2 ->
2180 incr_int (mul_int (untag_int c1 dbg) (decr_int c2 dbg) dbg) dbg
2181 | c1, c2 ->
2182 incr_int (mul_int (decr_int c1 dbg) (untag_int c2 dbg) dbg) dbg
2183
2184 let div_int_caml is_safe arg1 arg2 dbg =
2185 tag_int(div_int (untag_int arg1 dbg)
2186 (untag_int arg2 dbg) is_safe dbg) dbg
2187
2188 let mod_int_caml is_safe arg1 arg2 dbg =
2189 tag_int(mod_int (untag_int arg1 dbg)
2190 (untag_int arg2 dbg) is_safe dbg) dbg
2191
2192 let and_int_caml arg1 arg2 dbg =
2193 Cop(Cand, [arg1; arg2], dbg)
2194
2195 let or_int_caml arg1 arg2 dbg =
2196 Cop(Cor, [arg1; arg2], dbg)
2197
2198 let xor_int_caml arg1 arg2 dbg =
2199 Cop(Cor, [Cop(Cxor, [ignore_low_bit_int arg1;
2200 ignore_low_bit_int arg2], dbg);
2201 Cconst_int (1, dbg)], dbg)
2202
2203 let lsl_int_caml arg1 arg2 dbg =
2204 incr_int(lsl_int (decr_int arg1 dbg)
2205 (untag_int arg2 dbg) dbg) dbg
2206
2207 let lsr_int_caml arg1 arg2 dbg =
2208 Cop(Cor, [lsr_int arg1 (untag_int arg2 dbg) dbg;
2209 Cconst_int (1, dbg)], dbg)
2210
2211 let asr_int_caml arg1 arg2 dbg =
2212 Cop(Cor, [asr_int arg1 (untag_int arg2 dbg) dbg;
2213 Cconst_int (1, dbg)], dbg)
2214
2215 let int_comp_caml cmp arg1 arg2 dbg =
2216 tag_int(Cop(Ccmpi cmp,
2217 [arg1; arg2], dbg)) dbg
2218
2219 let stringref_unsafe arg1 arg2 dbg =
2220 tag_int(Cop(Cload (Byte_unsigned, Mutable),
2221 [add_int arg1 (untag_int arg2 dbg) dbg],
2222 dbg)) dbg
2223
2224 let stringref_safe arg1 arg2 dbg =
2225 tag_int
2226 (bind "str" arg1 (fun str ->
2227 bind "index" (untag_int arg2 dbg) (fun idx ->
2228 Csequence(
2229 make_checkbound dbg [string_length str dbg; idx],
2230 Cop(Cload (Byte_unsigned, Mutable),
2231 [add_int str idx dbg], dbg))))) dbg
2232
2233 let string_load size unsafe arg1 arg2 dbg =
2234 box_sized size dbg
2235 (bind "str" arg1 (fun str ->
2236 bind "index" (untag_int arg2 dbg) (fun idx ->
2237 check_bound unsafe size dbg
2238 (string_length str dbg)
2239 idx (unaligned_load size str idx dbg))))
2240
2241 let bigstring_load size unsafe arg1 arg2 dbg =
2242 box_sized size dbg
2243 (bind "ba" arg1 (fun ba ->
2244 bind "index" (untag_int arg2 dbg) (fun idx ->
2245 bind "ba_data"
2246 (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg))
2247 (fun ba_data ->
2248 check_bound unsafe size dbg
2249 (bigstring_length ba dbg)
2250 idx
2251 (unaligned_load size ba_data idx dbg)))))
2252
2253 let arrayref_unsafe kind arg1 arg2 dbg =
2254 match (kind : Lambda.array_kind) with
2255 | Pgenarray ->
2256 bind "arr" arg1 (fun arr ->
2257 bind "index" arg2 (fun idx ->
2258 Cifthenelse(is_addr_array_ptr arr dbg,
2259 dbg,
2260 addr_array_ref arr idx dbg,
2261 dbg,
2262 float_array_ref arr idx dbg,
2263 dbg)))
2264 | Paddrarray ->
2265 addr_array_ref arg1 arg2 dbg
2266 | Pintarray ->
2267 (* CR mshinwell: for int/addr_array_ref move "dbg" to first arg *)
2268 int_array_ref arg1 arg2 dbg
2269 | Pfloatarray ->
2270 float_array_ref arg1 arg2 dbg
2271
2272 let arrayref_safe kind arg1 arg2 dbg =
2273 match (kind : Lambda.array_kind) with
2274 | Pgenarray ->
2275 bind "index" arg2 (fun idx ->
2276 bind "arr" arg1 (fun arr ->
2277 bind "header" (get_header_without_profinfo arr dbg) (fun hdr ->
2278 if wordsize_shift = numfloat_shift then
2279 Csequence(
2280 make_checkbound dbg [addr_array_length_shifted hdr dbg; idx],
2281 Cifthenelse(is_addr_array_hdr hdr dbg,
2282 dbg,
2283 addr_array_ref arr idx dbg,
2284 dbg,
2285 float_array_ref arr idx dbg,
2286 dbg))
2287 else
2288 Cifthenelse(is_addr_array_hdr hdr dbg,
2289 dbg,
2290 Csequence(
2291 make_checkbound dbg [addr_array_length_shifted hdr dbg; idx],
2292 addr_array_ref arr idx dbg),
2293 dbg,
2294 Csequence(
2295 make_checkbound dbg [float_array_length_shifted hdr dbg; idx],
2296 float_array_ref arr idx dbg),
2297 dbg))))
2298 | Paddrarray ->
2299 bind "index" arg2 (fun idx ->
2300 bind "arr" arg1 (fun arr ->
2301 Csequence(
2302 make_checkbound dbg [
2303 addr_array_length_shifted
2304 (get_header_without_profinfo arr dbg) dbg; idx],
2305 addr_array_ref arr idx dbg)))
2306 | Pintarray ->
2307 bind "index" arg2 (fun idx ->
2308 bind "arr" arg1 (fun arr ->
2309 Csequence(
2310 make_checkbound dbg [
2311 addr_array_length_shifted
2312 (get_header_without_profinfo arr dbg) dbg; idx],
2313 int_array_ref arr idx dbg)))
2314 | Pfloatarray ->
2315 box_float dbg (
2316 bind "index" arg2 (fun idx ->
2317 bind "arr" arg1 (fun arr ->
2318 Csequence(
2319 make_checkbound dbg [
2320 float_array_length_shifted
2321 (get_header_without_profinfo arr dbg) dbg;
2322 idx],
2323 unboxed_float_array_ref arr idx dbg))))
2324
2325 type ternary_primitive =
2326 expression -> expression -> expression -> Debuginfo.t -> expression
2327
2328 let setfield_computed ptr init arg1 arg2 arg3 dbg =
2329 match assignment_kind ptr init with
2330 | Caml_modify ->
2331 return_unit dbg (addr_array_set arg1 arg2 arg3 dbg)
2332 | Caml_initialize ->
2333 return_unit dbg (addr_array_initialize arg1 arg2 arg3 dbg)
2334 | Simple ->
2335 return_unit dbg (int_array_set arg1 arg2 arg3 dbg)
2336
2337 let bytesset_unsafe arg1 arg2 arg3 dbg =
2338 return_unit dbg (Cop(Cstore (Byte_unsigned, Assignment),
2339 [add_int arg1 (untag_int arg2 dbg) dbg;
2340 ignore_high_bit_int (untag_int arg3 dbg)], dbg))
2341
2342 let bytesset_safe arg1 arg2 arg3 dbg =
2343 return_unit dbg
2344 (bind "str" arg1 (fun str ->
2345 bind "index" (untag_int arg2 dbg) (fun idx ->
2346 Csequence(
2347 make_checkbound dbg [string_length str dbg; idx],
2348 Cop(Cstore (Byte_unsigned, Assignment),
2349 [add_int str idx dbg;
2350 ignore_high_bit_int (untag_int arg3 dbg)],
2351 dbg)))))
2352
2353 let arrayset_unsafe kind arg1 arg2 arg3 dbg =
2354 return_unit dbg (match (kind: Lambda.array_kind) with
2355 | Pgenarray ->
2356 bind "newval" arg3 (fun newval ->
2357 bind "index" arg2 (fun index ->
2358 bind "arr" arg1 (fun arr ->
2359 Cifthenelse(is_addr_array_ptr arr dbg,
2360 dbg,
2361 addr_array_set arr index newval dbg,
2362 dbg,
2363 float_array_set arr index (unbox_float dbg newval)
2364 dbg,
2365 dbg))))
2366 | Paddrarray ->
2367 addr_array_set arg1 arg2 arg3 dbg
2368 | Pintarray ->
2369 int_array_set arg1 arg2 arg3 dbg
2370 | Pfloatarray ->
2371 float_array_set arg1 arg2 arg3 dbg
2372 )
2373
2374 let arrayset_safe kind arg1 arg2 arg3 dbg =
2375 return_unit dbg (match (kind: Lambda.array_kind) with
2376 | Pgenarray ->
2377 bind "newval" arg3 (fun newval ->
2378 bind "index" arg2 (fun idx ->
2379 bind "arr" arg1 (fun arr ->
2380 bind "header" (get_header_without_profinfo arr dbg) (fun hdr ->
2381 if wordsize_shift = numfloat_shift then
2382 Csequence(
2383 make_checkbound dbg [addr_array_length_shifted hdr dbg; idx],
2384 Cifthenelse(is_addr_array_hdr hdr dbg,
2385 dbg,
2386 addr_array_set arr idx newval dbg,
2387 dbg,
2388 float_array_set arr idx
2389 (unbox_float dbg newval)
2390 dbg,
2391 dbg))
2392 else
2393 Cifthenelse(
2394 is_addr_array_hdr hdr dbg,
2395 dbg,
2396 Csequence(
2397 make_checkbound dbg [addr_array_length_shifted hdr dbg; idx],
2398 addr_array_set arr idx newval dbg),
2399 dbg,
2400 Csequence(
2401 make_checkbound dbg [float_array_length_shifted hdr dbg; idx],
2402 float_array_set arr idx
2403 (unbox_float dbg newval) dbg),
2404 dbg)))))
2405 | Paddrarray ->
2406 bind "newval" arg3 (fun newval ->
2407 bind "index" arg2 (fun idx ->
2408 bind "arr" arg1 (fun arr ->
2409 Csequence(
2410 make_checkbound dbg [
2411 addr_array_length_shifted
2412 (get_header_without_profinfo arr dbg) dbg;
2413 idx],
2414 addr_array_set arr idx newval dbg))))
2415 | Pintarray ->
2416 bind "newval" arg3 (fun newval ->
2417 bind "index" arg2 (fun idx ->
2418 bind "arr" arg1 (fun arr ->
2419 Csequence(
2420 make_checkbound dbg [
2421 addr_array_length_shifted
2422 (get_header_without_profinfo arr dbg) dbg;
2423 idx],
2424 int_array_set arr idx newval dbg))))
2425 | Pfloatarray ->
2426 bind_load "newval" arg3 (fun newval ->
2427 bind "index" arg2 (fun idx ->
2428 bind "arr" arg1 (fun arr ->
2429 Csequence(
2430 make_checkbound dbg [
2431 float_array_length_shifted
2432 (get_header_without_profinfo arr dbg) dbg;
2433 idx],
2434 float_array_set arr idx newval dbg))))
2435 )
2436
2437 let bytes_set size unsafe arg1 arg2 arg3 dbg =
2438 return_unit dbg
2439 (bind "str" arg1 (fun str ->
2440 bind "index" (untag_int arg2 dbg) (fun idx ->
2441 bind "newval" arg3 (fun newval ->
2442 check_bound unsafe size dbg (string_length str dbg)
2443 idx (unaligned_set size str idx newval dbg)))))
2444
2445 let bigstring_set size unsafe arg1 arg2 arg3 dbg =
2446 return_unit dbg
2447 (bind "ba" arg1 (fun ba ->
2448 bind "index" (untag_int arg2 dbg) (fun idx ->
2449 bind "newval" arg3 (fun newval ->
2450 bind "ba_data"
2451 (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg))
2452 (fun ba_data ->
2453 check_bound unsafe size dbg (bigstring_length ba dbg)
2454 idx (unaligned_set size ba_data idx newval dbg))))))
2455
2456 (* Symbols *)
2457
2458 let cdefine_symbol (symb, (global: Cmmgen_state.is_global)) =
2459 match global with
2460 | Global -> [Cglobal_symbol symb; Cdefine_symbol symb]
2461 | Local -> [Cdefine_symbol symb]
2462
2463 let emit_block symb white_header cont =
2464 (* Headers for structured constants must be marked black in case we
2465 are in no-naked-pointers mode. See [caml_darken]. *)
2466 let black_header = Nativeint.logor white_header caml_black in
2467 Cint black_header :: cdefine_symbol symb @ cont
2468
2469 let emit_string_constant_fields s cont =
2470 let n = size_int - 1 - (String.length s) mod size_int in
2471 Cstring s :: Cskip n :: Cint8 n :: cont
2472
2473 let emit_boxed_int32_constant_fields n cont =
2474 let n = Nativeint.of_int32 n in
2475 if size_int = 8 then
2476 Csymbol_address caml_int32_ops :: Cint32 n :: Cint32 0n :: cont
2477 else
2478 Csymbol_address caml_int32_ops :: Cint n :: cont
2479
2480 let emit_boxed_int64_constant_fields n cont =
2481 let lo = Int64.to_nativeint n in
2482 if size_int = 8 then
2483 Csymbol_address caml_int64_ops :: Cint lo :: cont
2484 else begin
2485 let hi = Int64.to_nativeint (Int64.shift_right n 32) in
2486 if big_endian then
2487 Csymbol_address caml_int64_ops :: Cint hi :: Cint lo :: cont
2488 else
2489 Csymbol_address caml_int64_ops :: Cint lo :: Cint hi :: cont
2490 end
2491
2492 let emit_boxed_nativeint_constant_fields n cont =
2493 Csymbol_address caml_nativeint_ops :: Cint n :: cont
2494
2495 let emit_float_constant symb f cont =
2496 emit_block symb float_header (Cdouble f :: cont)
2497
2498 let emit_string_constant symb s cont =
2499 emit_block symb (string_header (String.length s))
2500 (emit_string_constant_fields s cont)
2501
2502 let emit_int32_constant symb n cont =
2503 emit_block symb boxedint32_header
2504 (emit_boxed_int32_constant_fields n cont)
2505
2506 let emit_int64_constant symb n cont =
2507 emit_block symb boxedint64_header
2508 (emit_boxed_int64_constant_fields n cont)
2509
2510 let emit_nativeint_constant symb n cont =
2511 emit_block symb boxedintnat_header
2512 (emit_boxed_nativeint_constant_fields n cont)
2513
2514 let emit_float_array_constant symb fields cont =
2515 emit_block symb (floatarray_header (List.length fields))
2516 (Misc.map_end (fun f -> Cdouble f) fields cont)
2517
2518 (* Generate the entry point *)
2519
2520 let entry_point namelist =
2521 let dbg = placeholder_dbg in
2522 let cconst_int i = Cconst_int (i, dbg ()) in
2523 let cconst_symbol sym = Cconst_symbol (sym, dbg ()) in
2524 let incr_global_inited () =
2525 Cop(Cstore (Word_int, Assignment),
2526 [cconst_symbol "caml_globals_inited";
2527 Cop(Caddi, [Cop(Cload (Word_int, Mutable),
2528 [cconst_symbol "caml_globals_inited"], dbg ());
2529 cconst_int 1], dbg ())], dbg ()) in
2530 let body =
2531 List.fold_right
2532 (fun name next ->
2533 let entry_sym = Compilenv.make_symbol ~unitname:name (Some "entry") in
2534 Csequence(Cop(Capply typ_void,
2535 [cconst_symbol entry_sym], dbg ()),
2536 Csequence(incr_global_inited (), next)))
2537 namelist (cconst_int 1) in
2538 let fun_name = "caml_program" in
2539 let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in
2540 Cfunction {fun_name;
2541 fun_args = [];
2542 fun_body = body;
2543 fun_codegen_options = [Reduce_code_size];
2544 fun_dbg;
2545 }
2546
2547 (* Generate the table of globals *)
2548
2549 let cint_zero = Cint 0n
2550
2551 let global_table namelist =
2552 let mksym name =
2553 Csymbol_address (Compilenv.make_symbol ~unitname:name (Some "gc_roots"))
2554 in
2555 Cdata(Cglobal_symbol "caml_globals" ::
2556 Cdefine_symbol "caml_globals" ::
2557 List.map mksym namelist @
2558 [cint_zero])
2559
2560 let reference_symbols namelist =
2561 let mksym name = Csymbol_address name in
2562 Cdata(List.map mksym namelist)
2563
2564 let global_data name v =
2565 Cdata(emit_string_constant (name, Global)
2566 (Marshal.to_string v []) [])
2567
2568 let globals_map v = global_data "caml_globals_map" v
2569
2570 (* Generate the master table of frame descriptors *)
2571
2572 let frame_table namelist =
2573 let mksym name =
2574 Csymbol_address (Compilenv.make_symbol ~unitname:name (Some "frametable"))
2575 in
2576 Cdata(Cglobal_symbol "caml_frametable" ::
2577 Cdefine_symbol "caml_frametable" ::
2578 List.map mksym namelist
2579 @ [cint_zero])
2580
2581 (* Generate the master table of Spacetime shapes *)
2582
2583 let spacetime_shapes namelist =
2584 let mksym name =
2585 Csymbol_address (
2586 Compilenv.make_symbol ~unitname:name (Some "spacetime_shapes"))
2587 in
2588 Cdata(Cglobal_symbol "caml_spacetime_shapes" ::
2589 Cdefine_symbol "caml_spacetime_shapes" ::
2590 List.map mksym namelist
2591 @ [cint_zero])
2592
2593 (* Generate the table of module data and code segments *)
2594
2595 let segment_table namelist symbol begname endname =
2596 let addsyms name lst =
2597 Csymbol_address (Compilenv.make_symbol ~unitname:name (Some begname)) ::
2598 Csymbol_address (Compilenv.make_symbol ~unitname:name (Some endname)) ::
2599 lst
2600 in
2601 Cdata(Cglobal_symbol symbol ::
2602 Cdefine_symbol symbol ::
2603 List.fold_right addsyms namelist [cint_zero])
2604
2605 let data_segment_table namelist =
2606 segment_table namelist "caml_data_segments" "data_begin" "data_end"
2607
2608 let code_segment_table namelist =
2609 segment_table namelist "caml_code_segments" "code_begin" "code_end"
2610
2611 (* Initialize a predefined exception *)
2612
2613 let predef_exception i name =
2614 let name_sym = Compilenv.new_const_symbol () in
2615 let data_items =
2616 emit_string_constant (name_sym, Local) name []
2617 in
2618 let exn_sym = "caml_exn_" ^ name in
2619 let tag = Obj.object_tag in
2620 let size = 2 in
2621 let fields =
2622 (Csymbol_address name_sym)
2623 :: (cint_const (-i - 1))
2624 :: data_items
2625 in
2626 let data_items =
2627 emit_block (exn_sym, Global) (block_header tag size) fields
2628 in
2629 Cdata data_items
2630
2631 (* Header for a plugin *)
2632
2633 let plugin_header units =
2634 let mk ((ui : Cmx_format.unit_infos),crc) : Cmxs_format.dynunit =
2635 { dynu_name = ui.ui_name;
2636 dynu_crc = crc;
2637 dynu_imports_cmi = ui.ui_imports_cmi;
2638 dynu_imports_cmx = ui.ui_imports_cmx;
2639 dynu_defines = ui.ui_defines
2640 } in
2641 global_data "caml_plugin_header"
2642 ({ dynu_magic = Config.cmxs_magic_number;
2643 dynu_units = List.map mk units }
2644 : Cmxs_format.dynheader)
2645
2646 (* To compile "let rec" over values *)
2647
2648 let fundecls_size fundecls =
2649 let sz = ref (-1) in
2650 List.iter
2651 (fun (f : Clambda.ufunction) ->
2652 let indirect_call_code_pointer_size =
2653 match f.arity with
2654 | 0 | 1 -> 0
2655 (* arity 1 does not need an indirect call handler.
2656 arity 0 cannot be indirect called *)
2657 | _ -> 1
2658 (* For other arities there is an indirect call handler.
2659 if arity >= 2 it is caml_curry...
2660 if arity < 0 it is caml_tuplify... *)
2661 in
2662 sz := !sz + 1 + 2 + indirect_call_code_pointer_size)
2663 fundecls;
2664 !sz
2665
2666 (* Emit constant closures *)
2667
2668 let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont =
2669 let closure_symbol (f : Clambda.ufunction) =
2670 if Config.flambda then
2671 cdefine_symbol (f.label ^ "_closure", global_symb)
2672 else
2673 []
2674 in
2675 match (fundecls : Clambda.ufunction list) with
2676 [] ->
2677 (* This should probably not happen: dead code has normally been
2678 eliminated and a closure cannot be accessed without going through
2679 a [Project_closure], which depends on the function. *)
2680 assert (clos_vars = []);
2681 cdefine_symbol symb @ clos_vars @ cont
2682 | f1 :: remainder ->
2683 let rec emit_others pos = function
2684 [] -> clos_vars @ cont
2685 | (f2 : Clambda.ufunction) :: rem ->
2686 if f2.arity = 1 || f2.arity = 0 then
2687 Cint(infix_header pos) ::
2688 (closure_symbol f2) @
2689 Csymbol_address f2.label ::
2690 cint_const f2.arity ::
2691 emit_others (pos + 3) rem
2692 else
2693 Cint(infix_header pos) ::
2694 (closure_symbol f2) @
2695 Csymbol_address(curry_function_sym f2.arity) ::
2696 cint_const f2.arity ::
2697 Csymbol_address f2.label ::
2698 emit_others (pos + 4) rem in
2699 Cint(black_closure_header (fundecls_size fundecls
2700 + List.length clos_vars)) ::
2701 cdefine_symbol symb @
2702 (closure_symbol f1) @
2703 if f1.arity = 1 || f1.arity = 0 then
2704 Csymbol_address f1.label ::
2705 cint_const f1.arity ::
2706 emit_others 3 remainder
2707 else
2708 Csymbol_address(curry_function_sym f1.arity) ::
2709 cint_const f1.arity ::
2710 Csymbol_address f1.label ::
2711 emit_others 4 remainder
2712
2713 (* Build the NULL terminated array of gc roots *)
2714
2715 let emit_gc_roots_table ~symbols cont =
2716 let table_symbol = Compilenv.make_symbol (Some "gc_roots") in
2717 Cdata(Cglobal_symbol table_symbol ::
2718 Cdefine_symbol table_symbol ::
2719 List.map (fun s -> Csymbol_address s) symbols @
2720 [Cint 0n])
2721 :: cont
2722
2723 (* Build preallocated blocks (used for Flambda [Initialize_symbol]
2724 constructs, and Clambda global module) *)
2725
2726 let preallocate_block cont { Clambda.symbol; exported; tag; fields } =
2727 let space =
2728 (* These words will be registered as roots and as such must contain
2729 valid values, in case we are in no-naked-pointers mode. Likewise
2730 the block header must be black, below (see [caml_darken]), since
2731 the overall record may be referenced. *)
2732 List.map (fun field ->
2733 match field with
2734 | None ->
2735 Cint (Nativeint.of_int 1 (* Val_unit *))
2736 | Some (Clambda.Uconst_field_int n) ->
2737 cint_const n
2738 | Some (Clambda.Uconst_field_ref label) ->
2739 Csymbol_address label)
2740 fields
2741 in
2742 let global = Cmmgen_state.(if exported then Global else Local) in
2743 let symb = (symbol, global) in
2744 let data =
2745 emit_block symb (block_header tag (List.length fields)) space
2746 in
2747 Cdata data :: cont
2748
2749 let emit_preallocated_blocks preallocated_blocks cont =
2750 let symbols =
2751 List.map (fun ({ Clambda.symbol }:Clambda.preallocated_block) -> symbol)
2752 preallocated_blocks
2753 in
2754 let c1 = emit_gc_roots_table ~symbols cont in
2755 List.fold_left preallocate_block c1 preallocated_blocks
2756