1 /**************************************************************************/
2 /* */
3 /* OCaml */
4 /* */
5 /* Xavier Leroy and Damien Doligez, 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 #define CAML_INTERNALS
17
18 /* 1. Allocation functions doing the same work as the macros in the
19 case where [Setup_for_gc] and [Restore_after_gc] are no-ops.
20 2. Convenience functions related to allocation.
21 */
22
23 #include <string.h>
24 #include "caml/alloc.h"
25 #include "caml/custom.h"
26 #include "caml/major_gc.h"
27 #include "caml/memory.h"
28 #include "caml/mlvalues.h"
29 #include "caml/stacks.h"
30 #include "caml/signals.h"
31
32 #define Setup_for_gc
33 #define Restore_after_gc
34
35 CAMLexport value caml_alloc (mlsize_t wosize, tag_t tag)
36 {
37 value result;
38 mlsize_t i;
39
40 CAMLassert (tag < 256);
41 CAMLassert (tag != Infix_tag);
42 if (wosize <= Max_young_wosize){
43 if (wosize == 0){
44 result = Atom (tag);
45 }else{
46 Alloc_small (result, wosize, tag);
47 if (tag < No_scan_tag){
48 for (i = 0; i < wosize; i++) Field (result, i) = Val_unit;
49 }
50 }
51 }else{
52 result = caml_alloc_shr (wosize, tag);
53 if (tag < No_scan_tag){
54 for (i = 0; i < wosize; i++) Field (result, i) = Val_unit;
55 }
56 result = caml_check_urgent_gc (result);
57 }
58 return result;
59 }
60
61 CAMLexport value caml_alloc_small (mlsize_t wosize, tag_t tag)
62 {
63 value result;
64
65 CAMLassert (wosize > 0);
66 CAMLassert (wosize <= Max_young_wosize);
67 CAMLassert (tag < 256);
68 Alloc_small (result, wosize, tag);
69 return result;
70 }
71
72 CAMLexport value caml_alloc_small_with_my_or_given_profinfo (mlsize_t wosize,
73 tag_t tag, uintnat profinfo)
74 {
75 if (profinfo == 0) {
76 return caml_alloc_small(wosize, tag);
77 }
78 else {
79 value result;
80
81 CAMLassert (wosize > 0);
82 CAMLassert (wosize <= Max_young_wosize);
83 CAMLassert (tag < 256);
84 Alloc_small_with_profinfo (result, wosize, tag, profinfo);
85 return result;
86 }
87 }
88
89 /* [n] is a number of words (fields) */
90 CAMLexport value caml_alloc_tuple(mlsize_t n)
91 {
92 return caml_alloc(n, 0);
93 }
94
95 /* [len] is a number of bytes (chars) */
96 CAMLexport value caml_alloc_string (mlsize_t len)
97 {
98 value result;
99 mlsize_t offset_index;
100 mlsize_t wosize = (len + sizeof (value)) / sizeof (value);
101
102 if (wosize <= Max_young_wosize) {
103 Alloc_small (result, wosize, String_tag);
104 }else{
105 result = caml_alloc_shr (wosize, String_tag);
106 result = caml_check_urgent_gc (result);
107 }
108 Field (result, wosize - 1) = 0;
109 offset_index = Bsize_wsize (wosize) - 1;
110 Byte (result, offset_index) = offset_index - len;
111 return result;
112 }
113
114 /* [len] is a number of bytes (chars) */
115 CAMLexport value caml_alloc_initialized_string (mlsize_t len, const char *p)
116 {
117 value result = caml_alloc_string (len);
118 memcpy((char *)String_val(result), p, len);
119 return result;
120 }
121
122 /* [len] is a number of words.
123 [mem] and [max] are relative (without unit).
124 */
125 CAMLexport value caml_alloc_final (mlsize_t len, final_fun fun,
126 mlsize_t mem, mlsize_t max)
127 {
128 return caml_alloc_custom(caml_final_custom_operations(fun),
129 len * sizeof(value), mem, max);
130 }
131
132 CAMLexport value caml_copy_string(char const *s)
133 {
134 mlsize_t len;
135 value res;
136
137 len = strlen(s);
138 res = caml_alloc_initialized_string(len, s);
139 return res;
140 }
141
142 CAMLexport value caml_alloc_array(value (*funct)(char const *),
143 char const ** arr)
144 {
145 CAMLparam0 ();
146 mlsize_t nbr, n;
147 CAMLlocal2 (v, result);
148
149 nbr = 0;
150 while (arr[nbr] != 0) nbr++;
151 result = caml_alloc (nbr, 0);
152 for (n = 0; n < nbr; n++) {
153 /* The two statements below must be separate because of evaluation
154 order (don't take the address &Field(result, n) before
155 calling funct, which may cause a GC and move result). */
156 v = funct(arr[n]);
157 caml_modify(&Field(result, n), v);
158 }
159 CAMLreturn (result);
160 }
161
162 /* [len] is a number of floats */
163 value caml_alloc_float_array(mlsize_t len)
164 {
165 #ifdef FLAT_FLOAT_ARRAY
166 mlsize_t wosize = len * Double_wosize;
167 value result;
168 /* For consistency with [caml_make_vect], which can't tell whether it should
169 create a float array or not when the size is zero, the tag is set to
170 zero when the size is zero. */
171 if (wosize <= Max_young_wosize){
172 if (wosize == 0)
173 return Atom(0);
174 else
175 Alloc_small (result, wosize, Double_array_tag);
176 }else {
177 result = caml_alloc_shr (wosize, Double_array_tag);
178 result = caml_check_urgent_gc (result);
179 }
180 return result;
181 #else
182 return caml_alloc (len, 0);
183 #endif
184 }
185
186
187 CAMLexport value caml_copy_string_array(char const ** arr)
188 {
189 return caml_alloc_array(caml_copy_string, arr);
190 }
191
192 CAMLexport int caml_convert_flag_list(value list, int *flags)
193 {
194 int res;
195 res = 0;
196 while (list != Val_int(0)) {
197 res |= flags[Int_val(Field(list, 0))];
198 list = Field(list, 1);
199 }
200 return res;
201 }
202
203 /* For compiling let rec over values */
204
205 /* [size] is a [value] representing number of words (fields) */
206 CAMLprim value caml_alloc_dummy(value size)
207 {
208 mlsize_t wosize = Long_val(size);
209 return caml_alloc (wosize, 0);
210 }
211
212 /* [size] is a [value] representing number of words (fields) */
213 CAMLprim value caml_alloc_dummy_function(value size,value arity)
214 {
215 /* the arity argument is used by the js_of_ocaml runtime */
216 return caml_alloc_dummy(size);
217 }
218
219 /* [size] is a [value] representing number of floats. */
220 CAMLprim value caml_alloc_dummy_float (value size)
221 {
222 mlsize_t wosize = Long_val(size) * Double_wosize;
223 return caml_alloc (wosize, 0);
224 }
225
226 CAMLprim value caml_alloc_dummy_infix(value vsize, value voffset)
227 {
228 mlsize_t wosize = Long_val(vsize), offset = Long_val(voffset);
229 value v = caml_alloc(wosize, Closure_tag);
230 if (offset > 0) {
231 v += Bsize_wsize(offset);
232 Hd_val(v) = Make_header(offset, Infix_tag, Caml_white);
233 }
234 return v;
235 }
236
237 CAMLprim value caml_update_dummy(value dummy, value newval)
238 {
239 mlsize_t size, i;
240 tag_t tag;
241
242 tag = Tag_val (newval);
243
244 if (tag == Double_array_tag){
245 CAMLassert (Wosize_val(newval) == Wosize_val(dummy));
246 CAMLassert (Tag_val(dummy) != Infix_tag);
247 Tag_val(dummy) = Double_array_tag;
248 size = Wosize_val (newval) / Double_wosize;
249 for (i = 0; i < size; i++) {
250 Store_double_flat_field (dummy, i, Double_flat_field (newval, i));
251 }
252 } else if (tag == Infix_tag) {
253 value clos = newval - Infix_offset_hd(Hd_val(newval));
254 CAMLassert (Tag_val(clos) == Closure_tag);
255 CAMLassert (Tag_val(dummy) == Infix_tag);
256 CAMLassert (Infix_offset_val(dummy) == Infix_offset_val(newval));
257 dummy = dummy - Infix_offset_val(dummy);
258 size = Wosize_val(clos);
259 CAMLassert (size == Wosize_val(dummy));
260 for (i = 0; i < size; i++) {
261 caml_modify (&Field(dummy, i), Field(clos, i));
262 }
263 } else {
264 CAMLassert (tag < No_scan_tag);
265 CAMLassert (Tag_val(dummy) != Infix_tag);
266 Tag_val(dummy) = tag;
267 size = Wosize_val(newval);
268 CAMLassert (size == Wosize_val(dummy));
269 for (i = 0; i < size; i++){
270 caml_modify (&Field(dummy, i), Field(newval, i));
271 }
272 }
273 return Val_unit;
274 }
275