162 lines
4.0 KiB
C
162 lines
4.0 KiB
C
/***********************************************************************/
|
|
/* */
|
|
/* Objective Caml */
|
|
/* */
|
|
/* Xavier Leroy and Damien Doligez, 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$ */
|
|
|
|
/* 1. Allocation functions doing the same work as the macros in the
|
|
case where [Setup_for_gc] and [Restore_after_gc] are no-ops.
|
|
2. Convenience functions related to allocation.
|
|
*/
|
|
|
|
#include <string.h>
|
|
#include "alloc.h"
|
|
#include "major_gc.h"
|
|
#include "memory.h"
|
|
#include "mlvalues.h"
|
|
#include "stacks.h"
|
|
|
|
#define Setup_for_gc
|
|
#define Restore_after_gc
|
|
|
|
value alloc (mlsize_t wosize, tag_t tag)
|
|
{
|
|
value result;
|
|
mlsize_t i;
|
|
|
|
Assert (wosize > 0);
|
|
if (wosize <= Max_young_wosize){
|
|
Alloc_small (result, wosize, tag);
|
|
if (tag < No_scan_tag){
|
|
for (i = 0; i < wosize; i++) Field (result, i) = 0;
|
|
}
|
|
}else{
|
|
result = alloc_shr (wosize, tag);
|
|
if (tag < No_scan_tag) memset (Bp_val (result), 0, Bsize_wsize (wosize));
|
|
result = check_urgent_gc (result);
|
|
}
|
|
return result;
|
|
}
|
|
|
|
value alloc_small (mlsize_t wosize, tag_t tag)
|
|
{
|
|
value result;
|
|
|
|
Assert (wosize > 0 && wosize <= Max_young_wosize);
|
|
Alloc_small (result, wosize, tag);
|
|
return result;
|
|
}
|
|
|
|
value alloc_tuple(mlsize_t n)
|
|
{
|
|
return alloc(n, 0);
|
|
}
|
|
|
|
value alloc_string (mlsize_t len)
|
|
{
|
|
value result;
|
|
mlsize_t offset_index;
|
|
mlsize_t wosize = (len + sizeof (value)) / sizeof (value);
|
|
|
|
if (wosize <= Max_young_wosize) {
|
|
Alloc_small (result, wosize, String_tag);
|
|
}else{
|
|
result = alloc_shr (wosize, String_tag);
|
|
result = check_urgent_gc (result);
|
|
}
|
|
Field (result, wosize - 1) = 0;
|
|
offset_index = Bsize_wsize (wosize) - 1;
|
|
Byte (result, offset_index) = offset_index - len;
|
|
return result;
|
|
}
|
|
|
|
value alloc_final (mlsize_t len, final_fun fun, mlsize_t mem, mlsize_t max)
|
|
{
|
|
value result = alloc_shr (len, Final_tag);
|
|
|
|
Field (result, 0) = (value) fun;
|
|
adjust_gc_speed (mem, max);
|
|
result = check_urgent_gc (result);
|
|
return result;
|
|
}
|
|
|
|
value copy_string(char *s)
|
|
{
|
|
int len;
|
|
value res;
|
|
|
|
len = strlen(s);
|
|
res = alloc_string(len);
|
|
bcopy(s, String_val(res), len);
|
|
return res;
|
|
}
|
|
|
|
value alloc_array(value (*funct)(char *), char ** arr)
|
|
{
|
|
mlsize_t nbr, n;
|
|
value v, result;
|
|
|
|
nbr = 0;
|
|
while (arr[nbr] != 0) nbr++;
|
|
if (nbr == 0) {
|
|
return Atom(0);
|
|
} else {
|
|
result = alloc (nbr, 0);
|
|
Begin_root(result);
|
|
for (n = 0; n < nbr; n++) {
|
|
/* The two statements below must be separate because of evaluation
|
|
order (don't take the address &Field(result, n) before
|
|
calling funct, which may cause a GC and move result). */
|
|
v = funct(arr[n]);
|
|
modify(&Field(result, n), v);
|
|
}
|
|
End_roots();
|
|
return result;
|
|
}
|
|
}
|
|
|
|
value copy_string_array(char **arr)
|
|
{
|
|
return alloc_array(copy_string, arr);
|
|
}
|
|
|
|
int convert_flag_list(value list, int *flags)
|
|
{
|
|
int res;
|
|
res = 0;
|
|
while (list != Val_int(0)) {
|
|
res |= flags[Int_val(Field(list, 0))];
|
|
list = Field(list, 1);
|
|
}
|
|
return res;
|
|
}
|
|
|
|
/* For compiling let rec over values */
|
|
|
|
value alloc_dummy(value size) /* ML */
|
|
{
|
|
mlsize_t wosize = Int_val(size);
|
|
|
|
if (wosize == 0) return Atom(0);
|
|
return alloc (wosize, 0);
|
|
}
|
|
|
|
value update_dummy(value dummy, value newval) /* ML */
|
|
{
|
|
mlsize_t size, i;
|
|
size = Wosize_val(newval);
|
|
Assert (size == Wosize_val(dummy));
|
|
Tag_val(dummy) = Tag_val(newval);
|
|
for (i = 0; i < size; i++)
|
|
modify(&Field(dummy, i), Field(newval, i));
|
|
return Val_unit;
|
|
}
|