96 |
#include "libguile/root.h" |
#include "libguile/root.h" |
97 |
#include "libguile/vectors.h" |
#include "libguile/vectors.h" |
98 |
#include "libguile/fluids.h" |
#include "libguile/fluids.h" |
99 |
|
#include "libguile/goops.h" |
100 |
#include "libguile/values.h" |
#include "libguile/values.h" |
101 |
|
|
102 |
#include "libguile/validate.h" |
#include "libguile/validate.h" |
2043 |
|
|
2044 |
nontoplevel_cdrxnoap: |
nontoplevel_cdrxnoap: |
2045 |
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); |
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); |
|
nontoplevel_cdrxbegin: |
|
2046 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2047 |
nontoplevel_begin: |
nontoplevel_begin: |
2048 |
while (!SCM_NULLP (SCM_CDR (x))) |
while (!SCM_NULLP (SCM_CDR (x))) |
2430 |
RETURN (scm_makprom (scm_closure (SCM_CDR (x), env))); |
RETURN (scm_makprom (scm_closure (SCM_CDR (x), env))); |
2431 |
|
|
2432 |
case (SCM_ISYMNUM (SCM_IM_DISPATCH)): |
case (SCM_ISYMNUM (SCM_IM_DISPATCH)): |
|
proc = SCM_CADR (x); /* unevaluated operands */ |
|
|
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); |
|
|
if (SCM_IMP (proc)) |
|
|
arg2 = *scm_ilookup (proc, env); |
|
|
else if (!SCM_CONSP (proc)) |
|
|
{ |
|
|
if (SCM_VARIABLEP (proc)) |
|
|
arg2 = SCM_VARIABLE_REF (proc); |
|
|
else |
|
|
arg2 = *scm_lookupcar (SCM_CDR (x), env, 1); |
|
|
} |
|
|
else |
|
|
{ |
|
|
arg2 = scm_list_1 (EVALCAR (proc, env)); |
|
|
t.lloc = SCM_CDRLOC (arg2); |
|
|
while (SCM_NIMP (proc = SCM_CDR (proc))) |
|
|
{ |
|
|
*t.lloc = scm_list_1 (EVALCAR (proc, env)); |
|
|
t.lloc = SCM_CDRLOC (*t.lloc); |
|
|
} |
|
|
} |
|
|
|
|
|
type_dispatch: |
|
|
/* The type dispatch code is duplicated here |
|
|
* (c.f. objects.c:scm_mcache_compute_cmethod) since that |
|
|
* cuts down execution time for type dispatch to 50%. |
|
|
*/ |
|
2433 |
{ |
{ |
2434 |
long i, n, end, mask; |
/* If not done yet, evaluate the operand forms. The result is a |
2435 |
SCM z = SCM_CDDR (x); |
* list of arguments stored in t.arg1, which is used to perform the |
2436 |
n = SCM_INUM (SCM_CAR (z)); /* maximum number of specializers */ |
* function dispatch. */ |
2437 |
proc = SCM_CADR (z); |
SCM operand_forms = SCM_CADR (x); |
2438 |
|
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); |
2439 |
if (SCM_NIMP (proc)) |
if (SCM_ILOCP (operand_forms)) |
2440 |
{ |
t.arg1 = *scm_ilookup (operand_forms, env); |
2441 |
/* Prepare for linear search */ |
else if (SCM_VARIABLEP (operand_forms)) |
2442 |
mask = -1; |
t.arg1 = SCM_VARIABLE_REF (operand_forms); |
2443 |
i = 0; |
else if (!SCM_CONSP (operand_forms)) |
2444 |
end = SCM_VECTOR_LENGTH (proc); |
t.arg1 = *scm_lookupcar (SCM_CDR (x), env, 1); |
|
} |
|
2445 |
else |
else |
2446 |
{ |
{ |
2447 |
/* Compute a hash value */ |
SCM tail = t.arg1 = scm_list_1 (EVALCAR (operand_forms, env)); |
2448 |
long hashset = SCM_INUM (proc); |
operand_forms = SCM_CDR (operand_forms); |
2449 |
long j = n; |
while (!SCM_NULLP (operand_forms)) |
2450 |
z = SCM_CDDR (z); |
{ |
2451 |
mask = SCM_INUM (SCM_CAR (z)); |
SCM new_tail = scm_list_1 (EVALCAR (operand_forms, env)); |
2452 |
proc = SCM_CADR (z); |
SCM_SETCDR (tail, new_tail); |
2453 |
i = 0; |
tail = new_tail; |
2454 |
t.arg1 = arg2; |
operand_forms = SCM_CDR (operand_forms); |
2455 |
if (SCM_NIMP (t.arg1)) |
} |
2456 |
do |
} |
2457 |
|
} |
2458 |
|
|
2459 |
|
/* The type dispatch code is duplicated below |
2460 |
|
* (c.f. objects.c:scm_mcache_compute_cmethod) since that |
2461 |
|
* cuts down execution time for type dispatch to 50%. */ |
2462 |
|
type_dispatch: /* inputs: x, t.arg1 */ |
2463 |
|
/* Type dispatch means to determine from the types of the function |
2464 |
|
* arguments (i. e. the 'signature' of the call), which method from |
2465 |
|
* a generic function is to be called. This process of selecting |
2466 |
|
* the right method takes some time. To speed it up, guile uses |
2467 |
|
* caching: Together with the macro call to dispatch the signatures |
2468 |
|
* of some previous calls to that generic function from the same |
2469 |
|
* place are stored (in the code!) in a cache that we call the |
2470 |
|
* 'method cache'. This is done since it is likely, that |
2471 |
|
* consecutive calls to dispatch from that position in the code will |
2472 |
|
* have the same signature. Thus, the type dispatch works as |
2473 |
|
* follows: First, determine a hash value from the signature of the |
2474 |
|
* actual arguments. Second, use this hash value as an index to |
2475 |
|
* find that same signature in the method cache stored at this |
2476 |
|
* position in the code. If found, you have also found the |
2477 |
|
* corresponding method that belongs to that signature. If the |
2478 |
|
* signature is not found in the method cache, you have to perform a |
2479 |
|
* full search over all signatures stored with the generic |
2480 |
|
* function. */ |
2481 |
|
{ |
2482 |
|
unsigned long int specializers; |
2483 |
|
unsigned long int hash_value; |
2484 |
|
unsigned long int cache_end_pos; |
2485 |
|
unsigned long int mask; |
2486 |
|
SCM method_cache; |
2487 |
|
|
2488 |
|
{ |
2489 |
|
SCM z = SCM_CDDR (x); |
2490 |
|
SCM tmp = SCM_CADR (z); |
2491 |
|
specializers = SCM_INUM (SCM_CAR (z)); |
2492 |
|
|
2493 |
|
/* Compute a hash value for searching the method cache. There |
2494 |
|
* are two variants for computing the hash value, a (rather) |
2495 |
|
* complicated one, and a simple one. For the complicated one |
2496 |
|
* explained below, tmp holds a number that is used in the |
2497 |
|
* computation. */ |
2498 |
|
if (SCM_INUMP (tmp)) |
2499 |
|
{ |
2500 |
|
/* Use the signature of the actual arguments to determine |
2501 |
|
* the hash value. This is done as follows: Each class has |
2502 |
|
* an array of random numbers, that are determined when the |
2503 |
|
* class is created. The integer 'hashset' is an index into |
2504 |
|
* that array of random numbers. Now, from all classes that |
2505 |
|
* are part of the signature of the actual arguments, the |
2506 |
|
* random numbers at index 'hashset' are taken and summed |
2507 |
|
* up, giving the hash value. The value of 'hashset' is |
2508 |
|
* stored at the call to dispatch. This allows to have |
2509 |
|
* different 'formulas' for calculating the hash value at |
2510 |
|
* different places where dispatch is called. This allows |
2511 |
|
* to optimize the hash formula at every individual place |
2512 |
|
* where dispatch is called, such that hopefully the hash |
2513 |
|
* value that is computed will directly point to the right |
2514 |
|
* method in the method cache. */ |
2515 |
|
unsigned long int hashset = SCM_INUM (tmp); |
2516 |
|
unsigned long int counter = specializers + 1; |
2517 |
|
SCM tmp_arg = t.arg1; |
2518 |
|
hash_value = 0; |
2519 |
|
while (!SCM_NULLP (tmp_arg) && counter != 0) |
2520 |
{ |
{ |
2521 |
i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t.arg1))) |
SCM class = scm_class_of (SCM_CAR (tmp_arg)); |
2522 |
[scm_si_hashsets + hashset]; |
hash_value += SCM_INSTANCE_HASH (class, hashset); |
2523 |
t.arg1 = SCM_CDR (t.arg1); |
tmp_arg = SCM_CDR (tmp_arg); |
2524 |
|
counter--; |
2525 |
} |
} |
2526 |
while (j-- && SCM_NIMP (t.arg1)); |
z = SCM_CDDR (z); |
2527 |
i &= mask; |
method_cache = SCM_CADR (z); |
2528 |
end = i; |
mask = SCM_INUM (SCM_CAR (z)); |
2529 |
} |
hash_value &= mask; |
2530 |
|
cache_end_pos = hash_value; |
2531 |
|
} |
2532 |
|
else |
2533 |
|
{ |
2534 |
|
/* This method of determining the hash value is much |
2535 |
|
* simpler: Set the hash value to zero and just perform a |
2536 |
|
* linear search through the method cache. */ |
2537 |
|
method_cache = tmp; |
2538 |
|
mask = (unsigned long int) ((long) -1); |
2539 |
|
hash_value = 0; |
2540 |
|
cache_end_pos = SCM_VECTOR_LENGTH (method_cache); |
2541 |
|
} |
2542 |
|
} |
2543 |
|
|
2544 |
/* Search for match */ |
{ |
2545 |
do |
/* Search the method cache for a method with a matching |
2546 |
{ |
* signature. Start the search at position 'hash_value'. The |
2547 |
long j = n; |
* hashing implementation uses linear probing for conflict |
2548 |
z = SCM_VELTS (proc)[i]; |
* resolution, that is, if the signature in question is not |
2549 |
t.arg1 = arg2; /* list of arguments */ |
* found at the starting index in the hash table, the next table |
2550 |
if (SCM_NIMP (t.arg1)) |
* entry is tried, and so on, until in the worst case the whole |
2551 |
do |
* cache has been searched, but still the signature has not been |
2552 |
|
* found. */ |
2553 |
|
SCM z; |
2554 |
|
do |
2555 |
|
{ |
2556 |
|
SCM args = t.arg1; /* list of arguments */ |
2557 |
|
z = SCM_VELTS (method_cache)[hash_value]; |
2558 |
|
while (!SCM_NULLP (args)) |
2559 |
{ |
{ |
2560 |
/* More arguments than specifiers => CLASS != ENV */ |
/* More arguments than specifiers => CLASS != ENV */ |
2561 |
if (! SCM_EQ_P (scm_class_of (SCM_CAR (t.arg1)), SCM_CAR (z))) |
SCM class_of_arg = scm_class_of (SCM_CAR (args)); |
2562 |
|
if (!SCM_EQ_P (class_of_arg, SCM_CAR (z))) |
2563 |
goto next_method; |
goto next_method; |
2564 |
t.arg1 = SCM_CDR (t.arg1); |
args = SCM_CDR (args); |
2565 |
z = SCM_CDR (z); |
z = SCM_CDR (z); |
2566 |
} |
} |
2567 |
while (j-- && SCM_NIMP (t.arg1)); |
/* Fewer arguments than specifiers => CAR != ENV */ |
2568 |
/* Fewer arguments than specifiers => CAR != ENV */ |
if (SCM_NULLP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z))) |
2569 |
if (!(SCM_IMP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z)))) |
goto apply_cmethod; |
2570 |
goto next_method; |
next_method: |
2571 |
apply_cmethod: |
hash_value = (hash_value + 1) & mask; |
2572 |
env = EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z)), |
} while (hash_value != cache_end_pos); |
2573 |
arg2, |
|
2574 |
SCM_CMETHOD_ENV (z)); |
/* No appropriate method was found in the cache. */ |
2575 |
x = SCM_CMETHOD_CODE (z); |
z = scm_memoize_method (x, t.arg1); |
2576 |
goto nontoplevel_cdrxbegin; |
|
2577 |
next_method: |
apply_cmethod: /* inputs: z, t.arg1 */ |
2578 |
i = (i + 1) & mask; |
{ |
2579 |
} while (i != end); |
SCM formals = SCM_CMETHOD_FORMALS (z); |
2580 |
|
env = EXTEND_ENV (formals, t.arg1, SCM_CMETHOD_ENV (z)); |
2581 |
z = scm_memoize_method (x, arg2); |
x = SCM_CMETHOD_BODY (z); |
2582 |
goto apply_cmethod; |
goto nontoplevel_begin; |
2583 |
|
} |
2584 |
|
} |
2585 |
} |
} |
2586 |
|
|
2587 |
case (SCM_ISYMNUM (SCM_IM_SLOT_REF)): |
case (SCM_ISYMNUM (SCM_IM_SLOT_REF)): |
2865 |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
2866 |
{ |
{ |
2867 |
x = SCM_ENTITY_PROCEDURE (proc); |
x = SCM_ENTITY_PROCEDURE (proc); |
2868 |
arg2 = SCM_EOL; |
t.arg1 = SCM_EOL; |
2869 |
goto type_dispatch; |
goto type_dispatch; |
2870 |
} |
} |
2871 |
else if (!SCM_I_OPERATORP (proc)) |
else if (!SCM_I_OPERATORP (proc)) |
3010 |
{ |
{ |
3011 |
x = SCM_ENTITY_PROCEDURE (proc); |
x = SCM_ENTITY_PROCEDURE (proc); |
3012 |
#ifdef DEVAL |
#ifdef DEVAL |
3013 |
arg2 = debug.info->a.args; |
t.arg1 = debug.info->a.args; |
3014 |
#else |
#else |
3015 |
arg2 = scm_list_1 (t.arg1); |
t.arg1 = scm_list_1 (t.arg1); |
3016 |
#endif |
#endif |
3017 |
goto type_dispatch; |
goto type_dispatch; |
3018 |
} |
} |
3106 |
{ |
{ |
3107 |
x = SCM_ENTITY_PROCEDURE (proc); |
x = SCM_ENTITY_PROCEDURE (proc); |
3108 |
#ifdef DEVAL |
#ifdef DEVAL |
3109 |
arg2 = debug.info->a.args; |
t.arg1 = debug.info->a.args; |
3110 |
#else |
#else |
3111 |
arg2 = scm_list_2 (t.arg1, arg2); |
t.arg1 = scm_list_2 (t.arg1, arg2); |
3112 |
#endif |
#endif |
3113 |
goto type_dispatch; |
goto type_dispatch; |
3114 |
} |
} |
3318 |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
3319 |
{ |
{ |
3320 |
#ifdef DEVAL |
#ifdef DEVAL |
3321 |
arg2 = debug.info->a.args; |
t.arg1 = debug.info->a.args; |
3322 |
#else |
#else |
3323 |
arg2 = scm_cons2 (t.arg1, arg2, scm_eval_args (x, env, proc)); |
t.arg1 = scm_cons2 (t.arg1, arg2, scm_eval_args (x, env, proc)); |
3324 |
#endif |
#endif |
3325 |
x = SCM_ENTITY_PROCEDURE (proc); |
x = SCM_ENTITY_PROCEDURE (proc); |
3326 |
goto type_dispatch; |
goto type_dispatch; |