GC_API void GC_CALL GC_debug_register_finalizer(void * obj,
GC_finalization_proc fn,
void * cd, GC_finalization_proc *ofn,
void * *ocd)
{
GC_finalization_proc my_old_fn = OFN_UNSET;
void * my_old_cd;
ptr_t base = GC_base(obj);
if (0 == base) {
/* We won't collect it, hence finalizer wouldn't be run. */
if (ocd) *ocd = 0;
if (ofn) *ofn = 0;
return;
}
if ((ptr_t)obj - base != sizeof(oh)) {
GC_err_printf(
"GC_debug_register_finalizer called with non-base-pointer %p\n",
obj);
}
if (0 == fn) {
GC_register_finalizer(base, 0, 0, &my_old_fn, &my_old_cd);
} else {
cd = GC_make_closure(fn, cd);
if (cd == 0) return; /* out of memory */
GC_register_finalizer(base, GC_debug_invoke_finalizer,
cd, &my_old_fn, &my_old_cd);
}
store_old(obj, my_old_fn, (struct closure *)my_old_cd, ofn, ocd);
}
/**
\brief Function which implements the nomRenewNoInit() method of NOMClass.
*/
NOM_Scope PNOMObject NOMLINK impl_NOMClass_nomRenewNoInit(NOMClass* nomSelf,
const gpointer nomObj,
CORBA_Environment *ev)
{
NOMClassPriv *ncp;
NOMClassData *nomThis = NOMClassGetData(nomSelf);
GC_PTR oldData;
GC_finalization_proc oldFinalizerFunc;
ncp=(NOMClassPriv*)_ncpObject;
/* Docs say the memory is first zeroed */
memset(nomObj, 0, ncp->mtab->ulInstanceSize);
/* Set mtab so it's an object */
((NOMObject*)nomObj)->mtab=ncp->mtab;
/* Register finalizer if the class uses nomUnInit */
ncp=(NOMClassPriv*)ncp->mtab->nomClsInfo;
if(ncp->ulClassFlags & NOM_FLG_NOMUNINIT_OVERRIDEN){
//nomPrintf("Registering finalizer for %s\n", ((NOMObject*)nomObj)->mtab->nomClassName);
GC_register_finalizer(nomObj, nomObjectFinalizer, NULL, &oldFinalizerFunc, &oldData);
}
/* NO call to _nomInit() */
/* Return statement to be customized: */
return nomObj;
}
static void *make_stack_copy_rec(intptr_t size)
{
CopiedStack *cs, **lk;
cs = MALLOC_ONE(CopiedStack);
cs->size = size;
lk = MALLOC_LINK();
cs->next = lk;
lk = MALLOC_LINK();
cs->prev = lk;
/* double linked list push */
*cs->next = *first_copied_stack;
if (*first_copied_stack)
*(*first_copied_stack)->prev = cs;
*cs->prev = NULL;
*first_copied_stack = cs;
GC_register_finalizer(cs, remove_cs, NULL, NULL, NULL);
scheme_num_copied_stacks++;
return (void *)cs;
}
static void reg(void *p) {
struct A *t = (struct A *)p;
t->count = count++;
#if MAKE_FINALIZATION_CYCLES
t->ptr = p; /* self-pointer, to see if it interferes with finalization */
#endif
GC_register_finalizer(p,fin,0,0,0);
}
options_t* options_new()
{
options_t* o = GC_MALLOC(sizeof(options_t));
o->num_args = 0;
o->args = NULL;
o->params = string_string_unordered_map_new();
GC_register_finalizer(o, &options_free, o, NULL, NULL);
return o;
}
kari_data_t* kari_create_data(void* ptr, size_t tag, void(*finalizer)(void*))
{
kari_data_t* data = (kari_data_t*)GC_MALLOC(sizeof(kari_data_t));
data->base.type = KARI_DATA;
data->ptr = ptr;
data->tag = tag;
data->finalizer = finalizer;
GC_register_finalizer(data, (void(*)(void*,void*))kari_gc_finalize_callback, 0, 0, 0);
return data;
}
str_grid_patch_filler_t* str_grid_patch_filler_new(const char* name,
void* context,
str_grid_patch_filler_vtable vtable)
{
ASSERT(vtable.start_filling_cells != NULL);
str_grid_patch_filler_t* filler = GC_MALLOC(sizeof(str_grid_patch_filler_t));
filler->name = string_dup(name);
filler->context = context;
filler->vtable = vtable;
GC_register_finalizer(filler, str_grid_patch_filler_free, filler, NULL, NULL);
return filler;
}
void GC_debug_register_finalizer(void * obj, GC_finalization_proc fn,
void * cd, GC_finalization_proc *ofn,
void * *ocd)
{
GC_finalization_proc my_old_fn;
void * my_old_cd;
ptr_t base = GC_base(obj);
if (0 == base) return;
if ((ptr_t)obj - base != sizeof(oh)) {
GC_err_printf(
"GC_debug_register_finalizer called with non-base-pointer %p\n",
obj);
}
if (0 == fn) {
GC_register_finalizer(base, 0, 0, &my_old_fn, &my_old_cd);
} else {
GC_register_finalizer(base, GC_debug_invoke_finalizer,
GC_make_closure(fn,cd), &my_old_fn, &my_old_cd);
}
store_old(obj, my_old_fn, (struct closure *)my_old_cd, ofn, ocd);
}
dfsch_object_t* dfsch_tcl_make_interpreter(Tcl_Interp* interp){
interpreter_t* i
= (interpreter_t*)dfsch_make_object(DFSCH_TCL_INTERPRETER_TYPE);
i->interpreter = interp;
i->active = 1;
i->owner = dfsch__get_thread_info();
GC_register_finalizer(i, (GC_finalization_proc)interpreter_finalizer,
NULL, NULL, NULL);
return (dfsch_object_t*)i;
}
polygon2_t* polygon2_new_with_ordering(point2_t* points, int* ordering, int num_points)
{
ASSERT(points != NULL);
ASSERT(num_points >= 3);
polygon2_t* poly = GC_MALLOC(sizeof(polygon2_t));
poly->vertices = polymec_malloc(sizeof(point2_t)*num_points);
memcpy(poly->vertices, points, sizeof(point2_t)*num_points);
poly->num_vertices = num_points;
poly->ordering = polymec_malloc(sizeof(int)*num_points);
memcpy(poly->ordering, ordering, sizeof(int)*num_points);
polygon2_compute_area(poly);
GC_register_finalizer(poly, polygon2_free, poly, NULL, NULL);
return poly;
}
rng_t* rng_new(const char* name, void* context,
uint32_t min, uint32_t max, rng_vtable vtable,
bool has_global_state, bool is_thread_safe)
{
ASSERT(min < max);
ASSERT(vtable.get != NULL);
rng_t* rng = GC_MALLOC(sizeof(rng_t));
rng->name = string_dup(name);
rng->context = context;
rng->min = min;
rng->max = max;
rng->vtable = vtable;
rng->has_global_state = has_global_state;
rng->is_thread_safe = is_thread_safe;
GC_register_finalizer(rng, rng_free, rng, NULL, NULL);
return rng;
}
st_func_t* st_func_from_func(const char* name, st_eval_func func,
st_func_homogeneity_t homogeneity,
st_func_constancy_t constancy,
int num_comp)
{
ASSERT(func != NULL);
ASSERT(num_comp > 0);
st_func_t* f = GC_MALLOC(sizeof(st_func_t));
f->name = string_dup(name);
f->context = NULL;
f->vtable.eval = func;
f->homogeneous = (homogeneity == ST_FUNC_HOMOGENEOUS);
f->constant = (constancy == ST_FUNC_CONSTANT);
f->num_comp = num_comp;
memset(f->derivs, 0, sizeof(st_func_t*)*4);
GC_register_finalizer(f, &st_func_free, f, NULL, NULL);
return f;
}
st_func_t* st_func_from_sp_func(sp_func_t* func)
{
ASSERT(func != NULL);
st_func_t* f = GC_MALLOC(sizeof(st_func_t));
f->name = string_dup(sp_func_name(func));
f->context = func;
f->vtable.eval = eval_sp_func;
f->homogeneous = sp_func_is_homogeneous(func);
f->constant = true;
f->num_comp = sp_func_num_comp(func);
memset(f->derivs, 0, sizeof(st_func_t*)*4);
for (int i = 1; i <= 4; ++i)
{
if (sp_func_has_deriv(func, i))
st_func_register_deriv(f, i, sp_func_deriv_new(func, i));
}
GC_register_finalizer(f, &st_func_free, f, NULL, NULL);
return f;
}
Region * NewRegion(void)
{
Region * result;
pthread_rwlock_t * lock;
Obj region_obj;
#ifndef DISABLE_GC
result = GC_malloc(sizeof(Region) + (MAX_THREADS + 1));
lock = GC_malloc_atomic(sizeof(*lock));
GC_register_finalizer(lock, LockFinalizer, NULL, NULL, NULL);
#else
result = calloc(1, sizeof(Region) + (MAX_THREADS + 1));
lock = malloc(sizeof(*lock));
#endif
pthread_rwlock_init(lock, NULL);
region_obj = NewBag(T_REGION, sizeof(Region *));
MakeBagPublic(region_obj);
*(Region **)(ADDR_OBJ(region_obj)) = result;
result->obj = region_obj;
result->lock = lock;
return result;
}
void scheme_remove_all_finalization(void *p)
{
GC_register_finalizer(p, NULL, NULL, NULL, NULL);
}
OOC_PTR RT0__NewObject(RT0__Struct td, ...) {
void *var, *ptr;
OOC_INT8 form = td->form;
int flags = td->flags;
if (form == RT0__strQualType) { /* get to base type of qualified type */
form = td->typeArgs[0]->form;
}
if (form == RT0__strRecord) { /* record */
int allocate;
int prefix;
int size = td->size;
if (size == 0) size++;
prefix = ROUND_SIZE(sizeof(RT0__Struct));
allocate = prefix + size;
if (flags & (1<<RT0__flagAtomic)) {
ptr = GC_MALLOC_ATOMIC(allocate);
} else {
ptr = GC_MALLOC(allocate);
}
if (ptr == NULL) {
_out_of_memory(allocate);
} else if (RT0__poisonHeap >= 0) {
memset(ptr, RT0__poisonHeap, allocate);
}
var = (char*)ptr+prefix;
OOC_TYPE_TAG(var) = td;
if (flags & (1<<RT0__flagVTable)) {
((void **) var)[0] = td->tbProcs;
}
#ifdef USE_BOEHM_GC
if (flags & (1<<RT0__flagFinalize)) {
GC_register_finalizer(ptr,
HandleFinalize, 0, (GC_finalization_proc *) 0, (GC_PTR *) 0);
}
#endif
} else if (form == RT0__strArray) { /* fixed size array */
int size = td->size;
if (size == 0) size++;
if (flags & (1<<RT0__flagAtomic)) {
var = GC_MALLOC_ATOMIC(size);
} else {
var = GC_MALLOC(size);
}
if (var == NULL) {
_out_of_memory(size);
} else if (RT0__poisonHeap >= 0) {
memset(var, RT0__poisonHeap, size);
}
} else { /* dynamic array */
int allocate;
va_list ap;
int i;
size_t size, prefix;
void* ptr;
OOC_LEN *dim;
/* calculate size of the block in bytes */
size = td->size;
va_start(ap, td);
for (i=0; i != td->len; i++) {
OOC_LEN len = va_arg(ap, OOC_LEN);
if (len < 0) {
_negative_length(len);
}
size *= len;
}
va_end(ap);
if (size == 0) size++;
/* calculate length of type tag prefix; round to maximum required alignment
of any basic type */
prefix = ROUND_SIZE(td->len*sizeof(OOC_LEN));
allocate = prefix + size;
if (flags & (1<<RT0__flagAtomic)) {
ptr = GC_MALLOC_ATOMIC(allocate);
} else {
ptr = GC_MALLOC(allocate);
}
if (ptr == NULL) {
_out_of_memory(allocate);
} else if (RT0__poisonHeap >= 0) {
memset(ptr, RT0__poisonHeap, allocate);
}
var = (char*)ptr+prefix;
/* set length of dimensions */
dim = (OOC_LEN*)var;
va_start(ap, td);
for (i=0; i != td->len; i++) {
*(--dim) = va_arg(ap, OOC_LEN);
}
va_end(ap);
}
return (OOC_PTR)var;
}
// This performs a Gram-Schmidt orthogonalization process on a monomial basis.
static void gram_schmidt(div_free_poly_basis_t* basis)
{
// Make a copy of the original basis vectors.
polynomial_vector_t v[basis->dim];
for (int i = 0; i < basis->dim; ++i)
v[i] = basis->vectors[i];
for (int i = 0; i < basis->dim; ++i)
{
// ui = vi.
polynomial_vector_t ui = v[i];
for (int j = 0; j < i; ++j)
{
polynomial_vector_t uj = basis->vectors[j];
// Compute <vi, uj>.
real_t vi_o_uj = inner_product(basis, &v[i], &uj);
// Compute <uj, uj>.
real_t uj2 = inner_product(basis, &uj, &uj);
ASSERT(uj2 > 0.0);
// Compute the projection of vi onto uj.
polynomial_vector_t proj_uj = {.x = scaled_polynomial_new(uj.x, vi_o_uj/uj2),
.y = scaled_polynomial_new(uj.y, vi_o_uj/uj2),
.z = scaled_polynomial_new(uj.z, vi_o_uj/uj2)};
// Subtract this off of ui.
polynomial_add(ui.x, -1.0, proj_uj.x);
polynomial_add(ui.y, -1.0, proj_uj.y);
polynomial_add(ui.z, -1.0, proj_uj.z);
}
// Copy the new ui basis vector into place.
basis->vectors[i] = ui;
}
}
div_free_poly_basis_t* spherical_div_free_poly_basis_new(int degree, point_t* x0, real_t radius)
{
ASSERT(radius > 0.0);
ASSERT(degree >= 0);
ASSERT(degree <= 2); // FIXME
div_free_poly_basis_t* basis = GC_MALLOC(sizeof(div_free_poly_basis_t));
basis->polytope = SPHERE;
basis->x0 = *x0;
basis->radius = radius;
basis->dim = basis_dim[degree];
basis->vectors = polymec_malloc(sizeof(polynomial_vector_t) * basis->dim);
GC_register_finalizer(basis, div_free_poly_basis_free, basis, NULL, NULL);
// Construct the naive monomial basis.
for (int i = 0; i < basis->dim; ++i)
{
basis->vectors[i].x = polynomial_from_monomials(degree, 1, &x_poly_coeffs[degree][i], &x_poly_x_powers[degree][i], &x_poly_y_powers[degree][i], &x_poly_z_powers[degree][i], NULL);
basis->vectors[i].y = polynomial_from_monomials(degree, 1, &y_poly_coeffs[degree][i], &y_poly_x_powers[degree][i], &y_poly_y_powers[degree][i], &y_poly_z_powers[degree][i], NULL);
basis->vectors[i].z = polynomial_from_monomials(degree, 1, &z_poly_coeffs[degree][i], &z_poly_x_powers[degree][i], &z_poly_y_powers[degree][i], &z_poly_z_powers[degree][i], NULL);
}
// Perform a Gram-Schmidt orthogonalization.
gram_schmidt(basis);
return basis;
}
void _tort_gc_register_finalizer_bdw(tort_v obj)
{
GC_register_finalizer(obj - sizeof(tort_header), _tort_finalization_proc, 0, 0, 0);
}
static void add_finalizer(void *v, void (*f)(void*,void*), void *data,
int prim, int ext,
void (**ext_oldf)(void *p, void *data),
void **ext_olddata,
int no_dup, int rmve)
{
finalizer_function oldf;
void *olddata;
Finalizations *fns, **fns_ptr, *prealloced;
Finalization *fn;
if (!traversers_registered) {
#ifdef MZ_PRECISE_GC
GC_REG_TRAV(scheme_rt_finalization, mark_finalization);
GC_REG_TRAV(scheme_rt_finalizations, mark_finalizations);
traversers_registered = 1;
#endif
REGISTER_SO(save_fns_ptr);
}
#ifndef MZ_PRECISE_GC
if (v != GC_base(v))
return;
#endif
/* Allocate everything first so that we're not changing
finalizations when finalizations could run: */
if (save_fns_ptr) {
fns_ptr = save_fns_ptr;
save_fns_ptr = NULL;
} else
fns_ptr = MALLOC_ONE(Finalizations*);
if (!ext && !rmve) {
fn = MALLOC_ONE_RT(Finalization);
#ifdef MZTAG_REQUIRED
fn->type = scheme_rt_finalization;
#endif
fn->f = f;
fn->data = data;
} else
fn = NULL;
if (!rmve) {
prealloced = MALLOC_ONE_RT(Finalizations); /* may not need this... */
#ifdef MZTAG_REQUIRED
prealloced->type = scheme_rt_finalizations;
#endif
} else
prealloced = NULL;
GC_register_eager_finalizer(v, prim ? 2 : 1, do_next_finalization, fns_ptr, &oldf, &olddata);
if (oldf) {
if (oldf != do_next_finalization) {
/* This happens if an extenal use of GC_ routines conflicts with us. */
scheme_warning("warning: non-MzScheme finalization on object dropped!");
} else {
*fns_ptr = *(Finalizations **)olddata;
save_fns_ptr = (Finalizations **)olddata;
*save_fns_ptr = NULL;
}
} else if (rmve) {
GC_register_finalizer(v, NULL, NULL, NULL, NULL);
save_fns_ptr = fns_ptr;
return;
}
if (!(*fns_ptr)) {
prealloced->lifetime = current_lifetime;
*fns_ptr = prealloced;
}
fns = *fns_ptr;
if (ext) {
if (ext_oldf)
*ext_oldf = fns->ext_f;
fns->ext_f = f;
if (ext_olddata)
*ext_olddata = fns->ext_data;
fns->ext_data = data;
if (!f && !fns->prim_first && !fns->scheme_first) {
/* Removed all finalization */
GC_register_finalizer(v, NULL, NULL, NULL, NULL);
save_fns_ptr = fns_ptr;
*save_fns_ptr = NULL;
}
} else {
if (prim) {
if (no_dup) {
/* Make sure it's not already here */
Finalization *fnx;
for (fnx = fns->prim_first; fnx; fnx = fnx->next) {
if (fnx->f == f && fnx->data == data) {
if (rmve) {
if (fnx->prev)
fnx->prev->next = fnx->next;
else
fns->prim_first = fnx->next;
if (fnx->next)
fnx->next->prev = fnx->prev;
else
fns->prim_last = fnx->prev;
}
fn = NULL;
break;
}
}
}
if (fn) {
fn->next = fns->prim_first;
fns->prim_first = fn;
if (!fn->next)
fns->prim_last = fn;
else
fn->next->prev = fn;
}
/* Removed all finalization? */
if (!fns->ext_f && !fns->prim_first && !fns->scheme_first) {
GC_register_finalizer(v, NULL, NULL, NULL, NULL);
save_fns_ptr = fns_ptr;
*save_fns_ptr = NULL;
}
} else {
fn->next = fns->scheme_first;
fns->scheme_first = fn;
if (!fn->next)
fns->scheme_last = fn;
else
fn->next->prev = fn;
}
}
}
