1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
|
/***********************************************************************/
/* */
/* Objective Caml */
/* */
/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
/* */
/* Copyright 1996 Institut National de Recherche en Informatique et */
/* en Automatique. All rights reserved. This file is distributed */
/* under the terms of the GNU Library General Public License. */
/* */
/***********************************************************************/
/* $Id$ */
/* Operations on objects */
#include "alloc.h"
#include "fail.h"
#include "gc.h"
#include "major_gc.h"
#include "memory.h"
#include "minor_gc.h"
#include "misc.h"
#include "mlvalues.h"
#include "prims.h"
value static_alloc(value size) /* ML */
{
return (value) stat_alloc((asize_t) Long_val(size));
}
value static_free(value blk) /* ML */
{
stat_free((void *) blk);
return Val_unit;
}
value static_resize(value blk, value new_size) /* ML */
{
return (value) stat_resize((char *) blk, (asize_t) Long_val(new_size));
}
value obj_is_block(value arg) /* ML */
{
return Val_bool(Is_block(arg));
}
value obj_tag(value arg) /* ML */
{
return Val_int(Tag_val(arg));
}
value obj_block(value tag, value size) /* ML */
{
value res;
mlsize_t sz, i;
tag_t tg;
sz = Long_val(size);
tg = Long_val(tag);
if (sz == 0) return Atom(tg);
res = alloc(sz, tg);
for (i = 0; i < sz; i++)
Field(res, i) = Val_long(0);
return res;
}
value obj_dup(value arg) /* ML */
{
CAMLparam1 (arg);
CAMLlocal1 (res);
mlsize_t sz, i;
tag_t tg;
sz = Wosize_val(arg);
if (sz == 0) return arg;
tg = Tag_val(arg);
res = alloc(sz, tg);
for (i = 0; i < sz; i++)
Field(res, i) = Field(arg, i);
CAMLreturn (res);
}
/* Shorten the given block to the given size and return void.
Raise Invalid_argument if the given size is less than or equal
to 0 or greater than the current size.
algorithm:
Change the length field of the header. Make up a white object
with the leftover part of the object: this is needed in the major
heap and harmless in the minor heap.
*/
value obj_truncate (value v, value newsize) /* ML */
{
mlsize_t new_wosize = Long_val (newsize);
header_t hd = Hd_val (v);
tag_t tag = Tag_hd (hd);
color_t color = Color_hd (hd);
mlsize_t wosize = Wosize_hd (hd);
mlsize_t i;
if (tag == Double_array_tag) new_wosize *= Double_wosize; /* PR#156 */
if (new_wosize <= 0 || new_wosize > wosize)
invalid_argument ("Obj.truncate");
if (new_wosize == wosize) return Val_unit;
/* PR#61: since we're about to lose our references to the elements
beyond new_wosize in v, erase them explicitly so that the GC
can darken them as appropriate. */
if (tag < No_scan_tag) {
for (i = new_wosize; i < wosize; i++){
modify(&Field(v, i), Val_unit);
#ifdef DEBUG
Field (v, i) = Debug_free_truncate;
#endif
}
}
Field (v, new_wosize) =
Make_header (Wosize_whsize (wosize-new_wosize), 0, Caml_white);
Hd_val (v) = Make_header (new_wosize, tag, color);
return Val_unit;
}
|
