[armedbear-cvs] r12181 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Fri Oct  9 16:38:25 2009
New Revision: 12181

Log:
Prevent nested compilation of CLOS generated methods.

This prevents recursive compilation of the same method
while it's already being compiled.

Modified:
   trunk/abcl/src/org/armedbear/lisp/Primitives.java
   trunk/abcl/src/org/armedbear/lisp/Symbol.java
   trunk/abcl/src/org/armedbear/lisp/clos.lisp
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Primitives.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Primitives.java	Fri Oct  9 16:38:25 2009
@@ -1449,6 +1449,7 @@
       }
     };
 
+  /** Stub to be replaced later when signal.lisp has been loaded. */
   // ### error
   private static final Primitive ERROR =
     new Primitive(Symbol.ERROR, "datum &rest arguments")
@@ -1470,6 +1471,18 @@
       }
     };
 
+  /** Stub replaced when compiler-pass2.lisp has been loaded */
+  // ### autocompile
+  private static final Primitive AUTOCOMPILE =
+    new Primitive(Symbol.AUTOCOMPILE, "function")
+    {
+      @Override
+      public LispObject execute(LispObject function) throws ConditionThrowable
+      {
+        return NIL;
+      }
+    };
+
   // ### signal
   private static final Primitive SIGNAL =
     new Primitive(Symbol.SIGNAL, "datum &rest arguments")

Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Symbol.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Symbol.java	Fri Oct  9 16:38:25 2009
@@ -2943,6 +2943,10 @@
     PACKAGE_JAVA.addExternalSymbol("JMETHOD-RETURN-TYPE");
 
   // External symbols in SYSTEM package.
+  public static final Symbol _ENABLE_AUTOCOMPILE_ =
+    PACKAGE_SYS.addExternalSymbol("*ENABLE-AUTOCOMPILE*");
+  public static final Symbol AUTOCOMPILE =
+    PACKAGE_SYS.addExternalSymbol("AUTOCOMPILE");
   public static final Symbol ENVIRONMENT =
     PACKAGE_SYS.addExternalSymbol("ENVIRONMENT");
   public static final Symbol FORWARD_REFERENCED_CLASS =

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Fri Oct  9 16:38:25 2009
@@ -1335,9 +1335,9 @@
                                    (slow-method-lookup ,gf args))))))
                    nil))))))
 
-    (when (and (fboundp 'compile)
+    (when (and (fboundp 'autocompile)
                (not (autoloadp 'compile)))
-      (setf code (or (compile nil code) code)))
+      (setf code (or (autocompile code) code)))
 
     code))
 
@@ -1535,7 +1535,7 @@
                                           (lambda (primary)
                                             `(funcall ,(%method-function primary) args nil))
                                           primaries)))))))))
-    (or (ignore-errors (compile nil emf-form))
+    (or (ignore-errors (autocompile emf-form))
         (coerce-to-function emf-form))))
 
 (defun generate-emf-lambda (method-function next-emfun)
@@ -1753,10 +1753,10 @@
                                                    :specializers (list class)
                                                    :function (if (autoloadp 'compile)
                                                                  method-function
-                                                                 (compile nil method-function))
+                                                                 (autocompile method-function))
                                                    :fast-function (if (autoloadp 'compile)
                                                                       fast-function
-                                                                      (compile nil fast-function))
+                                                                      (autocompile fast-function))
                                                    :slot-name slot-name)))
         (%add-method gf method)
         method))))
@@ -1778,10 +1778,10 @@
 ;;                    :function `(function ,method-function)
                    :function (if (autoloadp 'compile)
                                  method-function
-                                 (compile nil method-function))
+                                 (autocompile method-function))
                    :fast-function (if (autoloadp 'compile)
                                       fast-function
-                                      (compile nil fast-function))
+                                      (autocompile fast-function))
                    )))
 
 (fmakunbound 'class-name)

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Oct  9 16:38:25 2009
@@ -8758,4 +8758,11 @@
 (initialize-p2-handlers)
 
 
+(defun sys:autocompile (function)
+  (when sys:*enable-autocompile*
+    (let ((sys:*enable-autocompile* nil))
+      (values (compile nil function)))))
+
+(setf sys:*enable-autocompile* t)
+
 (provide "COMPILER-PASS2")