generics now dispatch as applicable structs

* libguile/eval.i.c (CEVAL, SCM_APPLY): Dispatch applicable structs
  before pure generics. In practice what this means is that we never hit
  the mcache case, because all pure generics are applicable structs.
  We're moving over to having generics dispatch themselves. Also, they
  don't prepend the struct as an arg; in order to have that effect, the
  user has closures.

* libguile/goops.c (scm_apply_generic, scm_call_generic_0):
  (scm_call_generic_1, scm_call_generic_2, scm_call_generic_3): Dispatch
  directly to the struct procedures.
  (scm_var_make_extended_generic): Remove a duplicate definition for
  scm_var_make_extended_generic.
  (create_standard_classes): Mark all instances of
  <applicable-struct-class> (themselves classes) as applicable classes.
  Meaning: generics are now applicable structs.

* libguile/goops.h (SCM_CLASS_CLASS_LAYOUT): The hashsets are actually
  uw slots -- or at least, making subclasses maps the int slots to be uw
  slots

* libguile/vm-i-system.c (call, goto/args, mv-call): Dispatch applicable
  structs in the VM.

* module/oop/goops/dispatch.scm (emit-linear-dispatch): Fix bug in the
  non-rest cache miss case.
  (delayed-compile): Rework to avoid fluids.
  (cache-dispatch): Don't call `equal?', it causes bootstrapping
  problems with the primitive-generic equal?. Using our own version is
  faster anyway.

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,7 +1227,24 @@ 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)
+	    if (SCM_STRUCT_APPLICABLE_P (proc))
+	      {
+	      operatorn:
+#ifdef DEVAL
+		RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc),
+				   debug.info->a.args,
+				   SCM_EOL));
+#else
+		RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc),
+				   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
@@ -1242,23 +1254,6 @@ dispatch:
 #endif
 		goto type_dispatch;
 	      }
-	    else if (SCM_STRUCT_APPLICABLE_P (proc))
-	      {
-	      operatorn:
-#ifdef DEVAL
-		RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc),
-				   scm_cons (proc, 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,
-								       env,
-								       proc))),
-				   SCM_EOL));
-#endif
-	      }
             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,7 +1759,18 @@ 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
+          debug.vect[0].a.proc = proc;
+#endif
+	  if (SCM_NIMP (proc))
+	    goto tail;
+	  else
+	    goto badproc;
+	}
+      else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
 	{
 #ifdef DEVAL
 	  args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
@@ -1773,25 +1779,6 @@ tail:
 #endif
 	  RETURN (scm_apply_generic (proc, args));
 	}
-      else if (SCM_STRUCT_APPLICABLE_P (proc))
-	{
-	  /* 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;
-	}
       else
         goto badproc;
     default:

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);
+  return scm_apply (SCM_STRUCT_PROCEDURE (gf), args, SCM_EOL);
-  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);
 }
 
 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_SET_VTABLE_FLAGS (scm_class_applicable_struct_class, SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
-     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>",

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 */ \
+  "uw" /* h0 */ \
-  "ur" /* h1 */ \
+  "uw" /* h1 */ \
-  "ur" /* h2 */ \
+  "uw" /* h2 */ \
-  "ur" /* h3 */ \
+  "uw" /* h3 */ \
-  "ur" /* h4 */ \
+  "uw" /* h4 */ \
-  "ur" /* h5 */ \
+  "uw" /* h5 */ \
-  "ur" /* h6 */ \
+  "uw" /* h6 */ \
-  "ur" /* h7 */ \
+  "uw" /* h7 */ \
   "pw" /* direct supers */ \
   "pw" /* direct slots */ \
   "pw" /* direct subclasses */ \

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;

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)
+       ((zero? timer)
-        (set! timer (1- timer))
+        (let ((dispatch (compute-dispatch-procedure
-        (cache-dispatch gf args))
+                         gf (slot-ref gf 'effective-methods))))
+          (slot-set! gf 'procedure dispatch)
+          (apply dispatch args)))
        (else
-        (let ((in-progress (fluid-ref *in-progress*)))
+        ;; interestingly, this catches recursive compilation attempts as
-          (if (memq gf in-progress)
+        ;; well; in that case, timer is negative
-              (cache-dispatch gf args)
+        (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))))))))))
 
 (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)))
+  (define (equal? x y) ; can't use the stock equal? because it's a generic...
-    (let lp ((cache (slot-ref gf 'effective-methods)))
+    (cond ((pair? x) (and (pair? y)
-      (cond ((null? cache)
+                          (eq? (car x) (car y))
-             (cache-miss gf args))
+                          (equal? (cdr x) (cdr y))))
-            ((equal? (vector-ref (car cache) 1) types)
+          ((null? x) (null? y))
-             (apply (vector-ref (car cache) 3) args))
+          (else #f)))
-            (else (lp (cdr cache)))))))
+  (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))