diff options
-rw-r--r-- | libguile/eval.i.c | 103 | ||||
-rw-r--r-- | libguile/goops.c | 24 | ||||
-rw-r--r-- | libguile/goops.h | 16 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 15 | ||||
-rw-r--r-- | module/oop/goops/dispatch.scm | 49 |
5 files changed, 101 insertions, 106 deletions
diff --git a/libguile/eval.i.c b/libguile/eval.i.c index 16ca837b4..d78f498d7 100644 --- a/libguile/eval.i.c +++ b/libguile/eval.i.c @@ -1026,22 +1026,20 @@ dispatch: goto nontoplevel_begin; } case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + if (SCM_STRUCT_APPLICABLE_P (proc)) + { + proc = SCM_STRUCT_PROCEDURE (proc); +#ifdef DEVAL + debug.info->a.proc = proc; +#endif + goto evap0; + } + else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { x = SCM_GENERIC_METHOD_CACHE (proc); arg1 = SCM_EOL; goto type_dispatch; } - else if (SCM_STRUCT_APPLICABLE_P (proc)) - { - arg1 = proc; - proc = SCM_STRUCT_PROCEDURE (proc); -#ifdef DEVAL - debug.info->a.proc = proc; - debug.info->a.args = scm_list_1 (arg1); -#endif - goto evap1; - } else goto badfun; case scm_tc7_subr_1: @@ -1153,7 +1151,15 @@ dispatch: goto nontoplevel_begin; } case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + if (SCM_STRUCT_APPLICABLE_P (proc)) + { + proc = SCM_STRUCT_PROCEDURE (proc); +#ifdef DEVAL + debug.info->a.proc = proc; +#endif + goto evap1; + } + else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { x = SCM_GENERIC_METHOD_CACHE (proc); #ifdef DEVAL @@ -1163,17 +1169,6 @@ dispatch: #endif goto type_dispatch; } - else if (SCM_STRUCT_APPLICABLE_P (proc)) - { - arg2 = arg1; - arg1 = proc; - proc = SCM_STRUCT_PROCEDURE (proc); -#ifdef DEVAL - debug.info->a.args = scm_cons (arg1, debug.info->a.args); - debug.info->a.proc = proc; -#endif - goto evap2; - } else goto badfun; case scm_tc7_subr_2: @@ -1232,33 +1227,33 @@ dispatch: RETURN (scm_i_gsubr_apply (proc, arg1, arg2, SCM_UNDEFINED)); #endif case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) - { - x = SCM_GENERIC_METHOD_CACHE (proc); -#ifdef DEVAL - arg1 = debug.info->a.args; -#else - arg1 = scm_list_2 (arg1, arg2); -#endif - goto type_dispatch; - } - else if (SCM_STRUCT_APPLICABLE_P (proc)) + if (SCM_STRUCT_APPLICABLE_P (proc)) { operatorn: #ifdef DEVAL RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc), - scm_cons (proc, debug.info->a.args), + debug.info->a.args, SCM_EOL)); #else RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc), - scm_cons2 (proc, arg1, - scm_cons (arg2, - scm_ceval_args (x, + scm_cons (arg1, + scm_cons (arg2, + scm_ceval_args (x, env, proc))), SCM_EOL)); #endif } + else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + { + x = SCM_GENERIC_METHOD_CACHE (proc); +#ifdef DEVAL + arg1 = debug.info->a.args; +#else + arg1 = scm_list_2 (arg1, arg2); +#endif + goto type_dispatch; + } else goto badfun; case scm_tc7_subr_0: @@ -1458,7 +1453,9 @@ dispatch: } #endif /* DEVAL */ case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + if (SCM_STRUCT_APPLICABLE_P (proc)) + goto operatorn; + else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { #ifdef DEVAL arg1 = debug.info->a.args; @@ -1468,8 +1465,6 @@ dispatch: x = SCM_GENERIC_METHOD_CACHE (proc); goto type_dispatch; } - else if (SCM_STRUCT_APPLICABLE_P (proc)) - goto operatorn; else goto badfun; case scm_tc7_subr_2: @@ -1764,33 +1759,25 @@ tail: #endif goto tail; case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + if (SCM_STRUCT_APPLICABLE_P (proc)) { + proc = SCM_STRUCT_PROCEDURE (proc); #ifdef DEVAL - args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); -#else - args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); + debug.vect[0].a.proc = proc; #endif - RETURN (scm_apply_generic (proc, args)); + if (SCM_NIMP (proc)) + goto tail; + else + goto badproc; } - else if (SCM_STRUCT_APPLICABLE_P (proc)) + else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { - /* operator */ #ifdef DEVAL args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); #else args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); #endif - arg1 = proc; - proc = SCM_STRUCT_PROCEDURE (proc); -#ifdef DEVAL - debug.vect[0].a.proc = proc; - debug.vect[0].a.args = scm_cons (arg1, args); -#endif - if (SCM_NIMP (proc)) - goto tail; - else - goto badproc; + RETURN (scm_apply_generic (proc, args)); } else goto badproc; diff --git a/libguile/goops.c b/libguile/goops.c index 88408f686..4a38f397c 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1800,40 +1800,31 @@ scm_mcache_compute_cmethod (SCM cache, SCM args) SCM scm_apply_generic (SCM gf, SCM args) { - SCM cmethod = scm_mcache_compute_cmethod (SCM_GENERIC_METHOD_CACHE (gf), args); - if (SCM_PROGRAM_P (cmethod)) - return scm_vm_apply (scm_the_vm (), cmethod, args); - else if (scm_is_pair (cmethod)) - return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)), - SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)), - args, - SCM_CMETHOD_ENV (cmethod))); - else - return scm_apply (cmethod, args, SCM_EOL); + return scm_apply (SCM_STRUCT_PROCEDURE (gf), args, SCM_EOL); } SCM scm_call_generic_0 (SCM gf) { - return scm_apply_generic (gf, SCM_EOL); + return scm_call_0 (SCM_STRUCT_PROCEDURE (gf)); } SCM scm_call_generic_1 (SCM gf, SCM a1) { - return scm_apply_generic (gf, scm_list_1 (a1)); + return scm_call_1 (SCM_STRUCT_PROCEDURE (gf), a1); } SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2) { - return scm_apply_generic (gf, scm_list_2 (a1, a2)); + return scm_call_2 (SCM_STRUCT_PROCEDURE (gf), a1, a2); } SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3) { - return scm_apply_generic (gf, scm_list_3 (a1, a2, a3)); + return scm_call_3 (SCM_STRUCT_PROCEDURE (gf), a1, a2, a3); } SCM @@ -1956,8 +1947,6 @@ static const char extension_gc_hint[] = "GOOPS extension"; static t_extension *extensions = 0; -SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic"); - void scm_c_extend_primitive_generic (SCM extended, SCM extension) { @@ -2554,8 +2543,7 @@ create_standard_classes (void) scm_class_class, scm_class_class, SCM_EOL); make_stdcls (&scm_class_applicable_struct_class, "<applicable-struct-class>", scm_class_class, scm_class_procedure_class, SCM_EOL); - /* SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class, - SCM_VTABLE_FLAG_APPLICABLE_VTABLE); */ + SCM_SET_VTABLE_FLAGS (scm_class_applicable_struct_class, SCM_VTABLE_FLAG_APPLICABLE_VTABLE); make_stdcls (&scm_class_method, "<method>", scm_class_class, scm_class_object, method_slots); make_stdcls (&scm_class_accessor_method, "<accessor-method>", diff --git a/libguile/goops.h b/libguile/goops.h index e77bbd995..57604a035 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -63,14 +63,14 @@ /* see also, SCM_VTABLE_BASE_LAYOUT, and build_class_class_slots */ #define SCM_CLASS_CLASS_LAYOUT \ "pw" /* redefined */ \ - "ur" /* h0 */ \ - "ur" /* h1 */ \ - "ur" /* h2 */ \ - "ur" /* h3 */ \ - "ur" /* h4 */ \ - "ur" /* h5 */ \ - "ur" /* h6 */ \ - "ur" /* h7 */ \ + "uw" /* h0 */ \ + "uw" /* h1 */ \ + "uw" /* h2 */ \ + "uw" /* h3 */ \ + "uw" /* h4 */ \ + "uw" /* h5 */ \ + "uw" /* h6 */ \ + "uw" /* h7 */ \ "pw" /* direct supers */ \ "pw" /* direct slots */ \ "pw" /* direct subclasses */ \ diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index df8424c3e..59a5520f7 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -761,6 +761,11 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1) APPLY_HOOK (); NEXT; } + if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x)) + { + sp[-nargs] = SCM_STRUCT_PROCEDURE (x); + goto vm_call; + } if (SCM_STRUCTP (x) && SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_PURE_GENERIC) { SCM args = SCM_EOL; @@ -845,6 +850,11 @@ VM_DEFINE_INSTRUCTION (54, goto_args, "goto/args", 1, -1, 1) APPLY_HOOK (); NEXT; } + if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x)) + { + sp[-nargs] = SCM_STRUCT_PROCEDURE (x); + goto vm_goto_args; + } if (SCM_STRUCTP (x) && SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_PURE_GENERIC) { SCM args = SCM_EOL; @@ -937,6 +947,11 @@ VM_DEFINE_INSTRUCTION (57, mv_call, "mv-call", 4, -1, 1) APPLY_HOOK (); NEXT; } + if (SCM_STRUCTP (x) && SCM_STRUCT_APPLICABLE_P (x)) + { + sp[-nargs] = SCM_STRUCT_PROCEDURE (x); + goto vm_mv_call; + } if (SCM_STRUCTP (x) && SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_PURE_GENERIC) { SCM args = SCM_EOL; diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm index ec03f599a..e08e642d4 100644 --- a/module/oop/goops/dispatch.scm +++ b/module/oop/goops/dispatch.scm @@ -72,7 +72,9 @@ (let lp ((methods methods) (free free) (exp `(cache-miss ,gf-sym - ,(if rest? `(cons* ,@args rest) args)))) + ,(if rest? + `(cons* ,@args rest) + `(list ,@args))))) (cond ((null? methods) (values `(,(if rest? `(,@args . rest) args) @@ -189,38 +191,41 @@ ;; get out before it blows o/~ ;; (define timer-init 10) -(define *in-progress* (make-fluid)) -(fluid-set! *in-progress* '()) - (define (delayed-compile gf) (let ((timer timer-init)) (lambda args + (set! timer (1- timer)) (cond - ((> timer 0) - (set! timer (1- timer)) - (cache-dispatch gf args)) + ((zero? timer) + (let ((dispatch (compute-dispatch-procedure + gf (slot-ref gf 'effective-methods)))) + (slot-set! gf 'procedure dispatch) + (apply dispatch args))) (else - (let ((in-progress (fluid-ref *in-progress*))) - (if (memq gf in-progress) - (cache-dispatch gf args) - (with-fluids ((*in-progress* (cons gf in-progress))) - (let ((dispatch (compute-dispatch-procedure - gf (slot-ref gf 'effective-methods)))) - (slot-set! gf 'procedure dispatch) - (apply dispatch args)))))))))) + ;; interestingly, this catches recursive compilation attempts as + ;; well; in that case, timer is negative + (cache-dispatch gf args)))))) (define (cache-dispatch gf args) (define (map-until n f ls) (if (or (zero? n) (null? ls)) '() (cons (f (car ls)) (map-until (1- n) f (cdr ls))))) - (let ((types (map-until (slot-ref gf 'n-specialized) class-of args))) - (let lp ((cache (slot-ref gf 'effective-methods))) - (cond ((null? cache) - (cache-miss gf args)) - ((equal? (vector-ref (car cache) 1) types) - (apply (vector-ref (car cache) 3) args)) - (else (lp (cdr cache))))))) + (define (equal? x y) ; can't use the stock equal? because it's a generic... + (cond ((pair? x) (and (pair? y) + (eq? (car x) (car y)) + (equal? (cdr x) (cdr y)))) + ((null? x) (null? y)) + (else #f))) + (if (slot-ref gf 'n-specialized) + (let ((types (map-until (slot-ref gf 'n-specialized) class-of args))) + (let lp ((cache (slot-ref gf 'effective-methods))) + (cond ((null? cache) + (cache-miss gf args)) + ((equal? (vector-ref (car cache) 1) types) + (apply (vector-ref (car cache) 3) args)) + (else (lp (cdr cache)))))) + (cache-miss gf args))) (define (cache-miss gf args) (apply (memoize-method! gf args (slot-ref gf '%cache)) args)) |