ecl/src/c/gfun.d

/* -*- mode: c; c-basic-offset: 8 -*- */
/*
    gfun.c -- Dispatch for generic functions.
*/
/*
    Copyright (c) 1990, Giuseppe Attardi.

    ECL is free software; you can redistribute it and/or
    modify it under the terms of the GNU Library General Public
    License as published by the Free Software Foundation; either
    version 2 of the License, or (at your option) any later version.

    See file '../Copyright' for full details.
*/

#include <string.h>
#include <ecl/ecl.h>
#include <ecl/ecl-inl.h>
#include <ecl/internal.h>
#include "newhash.h"

static cl_object generic_function_dispatch_vararg(cl_narg, ...);

cl_object
FEnot_funcallable_fixed()
{
        cl_env_ptr env = ecl_process_env();
        cl_object fun = env->function;
        FEerror("Not a funcallable instance ~A.", 1, fun);
        @(return);
}

cl_object
FEnot_funcallable_vararg(cl_narg narg, ...)
{
        return FEnot_funcallable_fixed();
}

static cl_object
user_function_dispatch(cl_narg narg, ...)
{
        int i;
        cl_object output;
	cl_env_ptr env = ecl_process_env();
	cl_object fun = env->function;
	struct ecl_stack_frame frame_aux;
	const cl_object frame = ecl_stack_frame_open(env, (cl_object)&frame_aux, narg);
        cl_va_list args; cl_va_start(args, narg, narg, 0);
        for (i = 0; i < narg; i++) {
                ECL_STACK_FRAME_SET(frame, i, cl_va_arg(args));
        }
        fun = fun->instance.slots[fun->instance.length - 1];
        output = ecl_apply_from_stack_frame(frame, fun);
        ecl_stack_frame_close(frame);
        return output;
}

static void
reshape_instance(cl_object x, int delta)
{
	cl_fixnum size = x->instance.length + delta;
	cl_object aux = ecl_allocate_instance(CLASS_OF(x), size);
        /* Except for the different size, this must match si_copy_instance */
        aux->instance.sig = x->instance.sig;
	memcpy(aux->instance.slots, x->instance.slots,
	       (delta < 0 ? aux->instance.length : x->instance.length) *
	       sizeof(cl_object));
	x->instance = aux->instance;
}

cl_object
clos_set_funcallable_instance_function(cl_object x, cl_object function_or_t)
{
	if (ecl_unlikely(!ECL_INSTANCEP(x)))
                FEwrong_type_nth_arg(@[clos::set-funcallable-instance-function],
                                     1, x, @[ext::instance]);
	if (x->instance.isgf == ECL_USER_DISPATCH) {
		reshape_instance(x, -1);
		x->instance.isgf = ECL_NOT_FUNCALLABLE;
	}
	if (function_or_t == Ct) {
		x->instance.isgf = ECL_STANDARD_DISPATCH;
                x->instance.entry = generic_function_dispatch_vararg;
	} else if (function_or_t == Cnil) {
		x->instance.isgf = ECL_NOT_FUNCALLABLE;
                x->instance.entry = FEnot_funcallable_vararg;
	} else if (Null(cl_functionp(function_or_t))) {
		FEwrong_type_argument(@'function', function_or_t);
	} else {
		reshape_instance(x, +1);
		x->instance.slots[x->instance.length - 1] = function_or_t;
		x->instance.isgf = ECL_USER_DISPATCH;
                x->instance.entry = user_function_dispatch;
	}
	@(return x)
}

cl_object
si_generic_function_p(cl_object x)
{
	@(return ((ECL_INSTANCEP(x) && (x->instance.isgf))? Ct : Cnil))
}

/**********************************************************************
 * METHOD HASH
 */

#define RECORD_KEY(e) ((e)[0])
#define RECORD_VALUE(e) ((e)[1])
#define RECORD_GEN(e) fix((e+2)[0])
#define RECORD_GEN_SET(e,v) ((e+2)[0]=MAKE_FIXNUM(v))

static cl_object
do_clear_method_hash(struct cl_env_struct *env, cl_object target)
{
	cl_object table = env->method_hash;
	cl_index i, total_size = table->vector.dim;
	if (target == Ct) {
		env->method_generation = 0;
		for (i = 0; i < total_size; i+=3) {
			table->vector.self.t[i] = OBJNULL;
			table->vector.self.t[i+1] = OBJNULL;
			table->vector.self.fix[i+2] = 0;
		}
#ifdef ECL_THREADS
		env->method_hash_clear_list = Cnil;
#endif
	} else {
		for (i = 0; i < total_size; i+=3) {
			cl_object key = table->vector.self.t[i];
			if (key != OBJNULL) {
				if (target == key->vector.self.t[0]) {
					table->vector.self.t[i] = OBJNULL;
					table->vector.self.fix[i+2] = 0;
				}
			}
		}
	}
}

void
_ecl_set_method_hash_size(struct cl_env_struct *env, cl_index size)
{
	env->method_spec_vector =
		si_make_vector(Ct, /* element type */
			       MAKE_FIXNUM(64), /* Maximum size */
			       Ct, /* adjustable */
			       MAKE_FIXNUM(0), /* fill pointer */
			       Cnil, /* displaced */
			       Cnil);
	env->method_hash =
		si_make_vector(Ct, /* element type */
			       MAKE_FIXNUM(3*size), /* Maximum size */
			       Cnil, /* adjustable */
			       Cnil, /* fill pointer */
			       Cnil, /* displaced */
			       Cnil);
	do_clear_method_hash(env, Ct);
}

cl_object
si_clear_gfun_hash(cl_object what)
{
	/*
	 * This function clears the generic function call hashes selectively.
	 *	what = Ct means clear the hash completely
	 *	what = generic function, means cleans only these entries
	 * If we work on a multithreaded environment, we simply enqueue these
	 * operations and wait for the destination thread to update its own hash.
	 */
#ifdef ECL_THREADS
	cl_object list;
	THREAD_OP_LOCK();
	list = cl_core.processes;
	loop_for_on_unsafe(list) {
		cl_object process = ECL_CONS_CAR(list);
		struct cl_env_struct *env = process->process.env;
		env->method_hash_clear_list = CONS(what, env->method_hash_clear_list);
	} end_loop_for_on_unsafe(list);
	THREAD_OP_UNLOCK();
#else
	do_clear_method_hash(&cl_env, what);
#endif
}

static cl_index
vector_hash_key(cl_object keys)
{
	cl_index c, n, a = GOLDEN_RATIO, b = GOLDEN_RATIO;
	for (c = 0, n = keys->vector.fillp; n >= 3; ) {
		c += keys->vector.self.index[--n];
		b += keys->vector.self.index[--n];
		a += keys->vector.self.index[--n];
		mix(a, b, c);
	}
	switch (n) {
	case 2:	b += keys->vector.self.index[--n];
	case 1:	a += keys->vector.self.index[--n];
		c += keys->vector.dim;
		mix(a,b,c);
	}
	return c;
}


/*
 * variation of ecl_gethash from hash.d, which takes an array of objects as key
 * It also assumes that entries are never removed except by clrhash.
 */

static cl_object *
search_method_hash(cl_env_ptr env, cl_object keys)
{
	cl_object table = env->method_hash;
	cl_index argno = keys->vector.fillp;
	cl_index i = vector_hash_key(keys);
	cl_index total_size = table->vector.dim;
	cl_fixnum min_gen, gen;
	cl_object *min_e;
	int k;
	i = i % total_size;
	i = i - (i % 3);
	min_gen = env->method_generation;
	min_e = 0;
	for (k = 20; k--; ) {
		cl_object *e = table->vector.self.t + i;
		cl_object hkey = RECORD_KEY(e);
		if (hkey == OBJNULL) {
			min_gen = -1;
			min_e = e;
			if (RECORD_VALUE(e) == OBJNULL) {
				/* This record is not only deleted but empty
				 * Hence we cannot find our method ahead */
				break;
			}
			/* Else we only know that the record has been
			 * delete, but we might find our data ahead. */
		} else if (argno == hkey->vector.fillp) {
			cl_index n;
			for (n = 0; n < argno; n++) {
				if (keys->vector.self.t[n] !=
				    hkey->vector.self.t[n])
					goto NO_MATCH;
			}
			min_e = e;
			goto FOUND;
		} else if (min_gen >= 0) {
		NO_MATCH:
			/* Unless we have found a deleted record, keep
			 * looking for the oldest record that we can
			 * overwrite with the new data. */
			gen = RECORD_GEN(e);
			if (gen < min_gen) {
				min_gen = gen;
				min_e = e;
			}
		}
		i += 3;
		if (i >= total_size) i = 0;
	}
	if (min_e == 0) {
		ecl_internal_error("search_method_hash");
	}
	RECORD_KEY(min_e) = OBJNULL;
	env->method_generation++;
 FOUND:
	/*
	 * Once we have reached here, we set the new generation of
	 * this record and perform a global shift so that the total
	 * generation number does not become too large and we can
	 * expire some elements.
	 */
	gen = env->method_generation;
	RECORD_GEN_SET(min_e, gen);
	if (gen >= total_size/2) {
		cl_object *e = table->vector.self.t;
		gen = 0.5*gen;
		env->method_generation -= gen;
		for (i = table->vector.dim; i; i-= 3, e += 3) {
			cl_fixnum g = RECORD_GEN(e) - gen;
			if (g <= 0) {
				RECORD_KEY(e) = OBJNULL;
				RECORD_VALUE(e) = Cnil;
				g = 0;
			}
			RECORD_GEN_SET(e, g);
		}
	}
	return min_e;
}

static cl_object
get_spec_vector(cl_env_ptr env, cl_object frame, cl_object gf)
{
	cl_object *args = frame->frame.base;
	cl_index narg = frame->frame.size;
	cl_object spec_how_list = GFUN_SPEC(gf);
	cl_object vector = env->method_spec_vector;
	cl_object *argtype = vector->vector.self.t;
	int spec_no = 1;
	argtype[0] = gf;
	loop_for_on_unsafe(spec_how_list) {
		cl_object spec_how = ECL_CONS_CAR(spec_how_list);
		cl_object spec_type = ECL_CONS_CAR(spec_how);
		int spec_position = fix(ECL_CONS_CDR(spec_how));
		if (spec_position >= narg)
			FEwrong_num_arguments(gf);
		argtype[spec_no++] =
			(ATOM(spec_type) ||
			 Null(ecl_memql(args[spec_position], spec_type))) ?
			cl_class_of(args[spec_position]) :
			args[spec_position];
		if (spec_no > vector->vector.dim)
			return OBJNULL;
	} end_loop_for_on_unsafe(spec_how_list);
	vector->vector.fillp = spec_no;
	return vector;
}

static cl_object
compute_applicable_method(cl_object frame, cl_object gf)
{
	/* method not cached */
	cl_object methods, arglist, func;
	cl_object *p;
	for (p = frame->frame.base + frame->frame.size, arglist = Cnil;
             p != frame->frame.base; ) {
		arglist = CONS(*(--p), arglist);
	}
	methods = funcall(3, @'compute-applicable-methods', gf, arglist);
	if (methods == Cnil) {
		func = funcall(3, @'no-applicable-method', gf, arglist);
		frame->frame.base[0] = OBJNULL;
		return func;
	} else {
		return funcall(4, @'clos::compute-effective-method', gf,
			       GFUN_COMB(gf), methods);
	}
}

cl_object
_ecl_standard_dispatch(cl_object frame, cl_object gf)
{
	cl_object func, vector;
        const cl_env_ptr env = frame->frame.env;
	/*
	 * We have to copy the frame because it might be stored in cl_env.values
	 * which will be wiped out by the next function call. However this only
	 * happens when we cannot reuse the values in the C stack.
	 */
#if !defined(ECL_USE_VARARG_AS_POINTER)
	struct ecl_stack_frame frame_aux;
	if (frame->frame.stack == (void*)0x1) {
                const cl_object new_frame = (cl_object)&frame_aux;
                ECL_STACK_FRAME_COPY(new_frame, frame);
                frame = new_frame;
	}
#endif
	
#ifdef ECL_THREADS
	/* See whether we have to clear the hash from some generic functions right now. */
	if (env->method_hash_clear_list != Cnil) {
		cl_object clear_list;
		THREAD_OP_LOCK();
		clear_list = env->method_hash_clear_list;
		loop_for_on_unsafe(clear_list) {
			do_clear_method_hash(&cl_env, ECL_CONS_CAR(clear_list));
		} end_loop_for_on_unsafe(clear_list);
		env->method_hash_clear_list = Cnil;
		THREAD_OP_UNLOCK();
	}
#endif
	vector = get_spec_vector(env, frame, gf);
	if (vector == OBJNULL) {
		func = compute_applicable_method(frame, gf);
	} else {
		cl_object *e = search_method_hash(env, vector);
		if (RECORD_KEY(e) != OBJNULL) {
			func = RECORD_VALUE(e);
		} else {
			cl_object keys = cl_copy_seq(vector);
			func = compute_applicable_method(frame, gf);
			if (RECORD_KEY(e) != OBJNULL) {
				/* The cache might have changed while we
				 * computed applicable methods */
				e = search_method_hash(env, vector);
			}
			RECORD_KEY(e) = keys;
			RECORD_VALUE(e) = func;
		}
	}
	func = cl_funcall(3, func, frame, Cnil);
	/* Only need to close the copy */
#if !defined(ECL_USE_VARARG_AS_POINTER)
	if (frame == (cl_object)&frame_aux)
		ecl_stack_frame_close(frame);
#endif
	return func;
}

static cl_object
generic_function_dispatch_vararg(cl_narg narg, ...)
{
        cl_object output;
        ECL_STACK_FRAME_VARARGS_BEGIN(narg, narg, frame);
	output = _ecl_standard_dispatch(frame, frame->frame.env->function);
        ECL_STACK_FRAME_VARARGS_END(frame);
        return output;
}