mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-17 03:00:21 +02:00
Code Activity

fix up some assumptions that cmethods were lists

Browse source 
* libguile/eval.i.c (type_dispatch, apply_vm_cmethod)
  (apply_memoized_cmethod): Tweak the nastiness a bit more so as to deal
  with the '(no-method) empty entries. I would like to stop the search if
  the cdr isn't a pair, but currently with the inlined memoized bits, the
  cdr is a pair. The fix would be to make the memoizer return a procedure
  and not the already-inlined bits -- slightly slower but the vm will be
  faster anyway.

* libguile/objects.c (scm_mcache_lookup_cmethod): Same fixes here.

* oop/goops/dispatch.scm (cache-hashval, cache-try-hash!): Allow non-list
  cmethod tails.
This commit is contained in:
Andy Wingo 2008-10-30 15:50:48 +01:00
parent 5487977b1b
commit 05b37c17ff
3 changed files with 27 additions and 19 deletions
Download patch file Download diff file Expand all files Collapse all files

23
libguile/eval.i.c
View file

@ -856,8 +856,11 @@ dispatch:
z = SCM_CDR (z); z = SCM_CDR (z);
} }
/* Fewer arguments than specifiers => CAR != CLASS */ /* Fewer arguments than specifiers => CAR != CLASS */
if (!SCM_CLASSP (SCM_CAR (z))) if (!scm_is_pair (z))
goto apply_cmethod; goto apply_vm_cmethod;
else if (!SCM_CLASSP (SCM_CAR (z))
&& !scm_is_symbol (SCM_CAR (z)))
goto apply_memoized_cmethod;
next_method: next_method:
hash_value = (hash_value + 1) & mask; hash_value = (hash_value + 1) & mask;
} while (hash_value != cache_end_pos); } while (hash_value != cache_end_pos);
@ -865,18 +868,20 @@ dispatch:
/* No appropriate method was found in the cache. */ /* No appropriate method was found in the cache. */
z = scm_memoize_method (x, arg1); z = scm_memoize_method (x, arg1);
apply_cmethod: /* inputs: z, arg1 */ if (scm_is_pair (z))
goto apply_memoized_cmethod;
apply_vm_cmethod:
proc = z;
PREP_APPLY (proc, arg1);
goto apply_proc;
apply_memoized_cmethod: /* inputs: z, arg1 */
{ {
if (scm_is_pair (z)) {
SCM formals = SCM_CMETHOD_FORMALS (z); SCM formals = SCM_CMETHOD_FORMALS (z);
env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z)); env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
x = SCM_CMETHOD_BODY (z); x = SCM_CMETHOD_BODY (z);
goto nontoplevel_begin; goto nontoplevel_begin;
} else {
proc = z;
PREP_APPLY (proc, arg1);
goto apply_proc;
}
} }
} }
} }

5
libguile/objects.c
View file

@ -138,8 +138,9 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args)
z = SCM_CDR (z); z = SCM_CDR (z);
} }
while (j-- && !scm_is_null (ls)); while (j-- && !scm_is_null (ls));
/* Fewer arguments than specifiers => CAR != CLASS */ /* Fewer arguments than specifiers => CAR != CLASS or `no-method' */
if (!SCM_CLASSP (SCM_CAR (z))) if (!scm_is_pair (z)
|| (!SCM_CLASSP (SCM_CAR (z)) && !scm_is_symbol (SCM_CAR (z))))
return z; return z;
next_method: next_method:
i = (i + 1) & mask; i = (i + 1) & mask;

6
oop/goops/dispatch.scm
View file

@ -176,7 +176,8 @@
(let ((hashset-index (+ hashset-index hashset))) (let ((hashset-index (+ hashset-index hashset)))
(do ((sum 0) (do ((sum 0)
(classes entry (cdr classes))) (classes entry (cdr classes)))
((not (struct? (car classes))) sum) ((not (and (pair? classes) (struct? (car classes))))
sum)
(set! sum (+ sum (struct-ref (car classes) hashset-index)))))) (set! sum (+ sum (struct-ref (car classes) hashset-index))))))
;;; FIXME: the throw probably is expensive, given that this function ;;; FIXME: the throw probably is expensive, given that this function
@ -191,7 +192,8 @@
((null? ls) max-misses) ((null? ls) max-misses)
(do ((i (logand mask (cache-hashval hashset (car ls))) (do ((i (logand mask (cache-hashval hashset (car ls)))
(logand mask (+ i 1)))) (logand mask (+ i 1))))
((not (struct? (car (vector-ref cache i)))) ((and (pair? (vector-ref cache i))
(eq? (car (vector-ref cache i)) 'no-method))
(vector-set! cache i (car ls))) (vector-set! cache i (car ls)))
(set! misses (+ 1 misses)) (set! misses (+ 1 misses))
(if (>= misses min-misses) (if (>= misses min-misses)