[armedbear-cvs] r13150 - branches/unsafe-p-removal/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Sat Jan 15 14:49:11 2011
New Revision: 13150

Log:
Add basic support for compiler 'listeners' or callbacks:
infrastructure to help debug the compiler.

Modified:
   branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
   branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
   branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Sat Jan 15 14:49:11 2011
@@ -1020,7 +1020,6 @@
 
 (defun finalize-code-attribute (code parent class)
   "Prepares the `code' attribute for serialization, within method `parent'."
-  (declare (ignore parent))
   (let* ((handlers (code-exception-handlers code))
          (c (finalize-code
                      (code-code code)
@@ -1028,6 +1027,8 @@
                             (mapcar #'exception-end-pc handlers)
                             (mapcar #'exception-handler-pc handlers))
                      t)))
+    (invoke-callbacks :code-finalized class parent
+                      (coerce c 'list) handlers)
     (unless (code-max-stack code)
       (setf (code-max-stack code)
             (analyze-stack c (mapcar #'exception-handler-pc handlers))))

Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
==============================================================================
--- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	(original)
+++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	Sat Jan 15 14:49:11 2011
@@ -721,6 +721,12 @@
       (let ((opcode (instruction-opcode instruction)))
         (setf depth (+ depth instruction-stack))
         (setf (instruction-depth instruction) depth)
+        (unless (<= 0 depth)
+          (internal-compiler-error "Stack inconsistency detected ~
+                                    in ~A at index ~D: ~
+                                    negative depth ~S."
+                                   (compiland-name *current-compiland*)
+                                   i depth))
         (when (branch-p opcode)
           (let ((label (car (instruction-args instruction))))
             (declare (type symbol label))

Modified: branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/jvm.lisp	Sat Jan 15 14:49:11 2011
@@ -53,6 +53,14 @@
 (defvar *closure-variables* nil)
 
 (defvar *enable-dformat* nil)
+(defvar *callbacks* nil
+  "A list of functions to be called by the compiler and code generator
+in order to generate 'compilation events'.")
+
+(declaim (inline invoke-callbacks))
+(defun invoke-callbacks (&rest args)
+  (dolist (cb *callbacks*)
+    (apply cb args)))
 
 #+nil
 (defun dformat (destination control-string &rest args)