[movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv1564

Modified Files:
	inspect.lisp 
Log Message:
Added operators objects-equal (a tool for GC debugging), and
%object-lispval and %lispval-object.

Date: Tue Jul 20 05:37:59 2004
Author: ffjeld

Index: movitz/losp/muerte/inspect.lisp
diff -u movitz/losp/muerte/inspect.lisp:1.25 movitz/losp/muerte/inspect.lisp:1.26
--- movitz/losp/muerte/inspect.lisp:1.25	Sat Jul 17 12:32:16 2004
+++ movitz/losp/muerte/inspect.lisp	Tue Jul 20 05:37:59 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 24 09:50:41 2003
 ;;;;                
-;;;; $Id: inspect.lisp,v 1.25 2004/07/17 19:32:16 ffjeld Exp $
+;;;; $Id: inspect.lisp,v 1.26 2004/07/20 12:37:59 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -204,6 +204,84 @@
      (copy-funobj old))
     (structure-object
      (copy-structure old))))
+
+(defvar *objects-equalp-last-x*)
+(defvar *objects-equalp-last-y*)
+
+(defun objects-equalp (x y)
+  (setf *objects-equalp-last-x* x
+	*objects-equalp-last-y* y)
+  (or (eql x y)
+      (if (not (and (typep x 'pointer)
+		    (typep y 'pointer)))
+	  nil
+	(macrolet ((test (accessor &rest args)
+		     `(objects-equalp (,accessor x , at args)
+				      (,accessor y , at args))))
+	  (typecase x
+	    (bignum
+	     (= x y))
+	    (function
+	     (and (test funobj-code-vector)
+		  (test funobj-code-vector%1op)
+		  (test funobj-code-vector%2op)
+		  (test funobj-code-vector%3op)
+		  (test funobj-lambda-list)
+		  (test funobj-name)
+		  (test funobj-num-constants)
+		  (test funobj-num-jumpers)
+		  (dotimes (i (funobj-num-constants x) t)
+		    (unless (test funobj-constant-ref i)))))
+	    (vector
+	     (and (typep y 'vector)
+		  (test array-element-type)
+		  (every #'objects-equalp x y)))
+	    (cons
+	     (and (typep y 'cons)
+		  (test car)
+		  (test cdr)))
+	    (structure-object
+	     (and (typep y 'structure-object)
+		  (test structure-object-name)
+		  (test structure-object-length)
+		  (dotimes (i (structure-object-length x) t)
+		    (unless (test structure-ref i)
+		      (return nil)))))
+	    (std-instance
+	     (and (typep y 'std-instance)
+		  (test std-instance-class)
+		  (test std-instance-slots))))))))
+
+(define-compiler-macro %lispval-object (integer &environment env)
+  "Return the object that is wrapped in the 32-bit integer lispval."
+  (if (movitz:movitz-constantp integer env)
+      (let ((word (movitz:movitz-eval integer env)))
+	(check-type word (unsigned-byte 32))
+	`(with-inline-assembly (:returns :register)
+	   (:movl ,word (:result-register))))
+    `(with-inline-assembly (:returns :register)
+       (:compile-form (:result-mode :eax) ,integer)
+       (:call-global-pf unbox-u32)
+       (:movl :ecx (:result-register)))))
+
+(defun %lispval-object (integer)
+  "Return the object that is wrapped in the 32-bit integer lispval."
+  (compiler-macro-call %lispval-object integer))
+
+(define-compiler-macro %object-lispval (object &environment env)
+  "Return the integer lispval that corresponds to object.
+Obviously, this correspondence is not guaranteed to hold e.g. across GC."
+  (if (movitz:movitz-constantp object env)
+      (movitz:movitz-intern (movitz:movitz-read (movitz:movitz-eval object env)) 'word)
+    `(with-inline-assembly (:returns :eax)
+       (:compile-form (:result-mode :eax) ,object)
+       (:movl :eax :ecx)
+       (:call-local-pf box-u32-ecx))))
+
+(defun %object-lispval (object)
+  "Return the integer lispval that corresponds to object.
+Obviously, this correspondence is not guaranteed to hold e.g. across GC."
+  (compiler-macro-call %object-lispval object))
 
 (defun location-in-object-p (object location)
   "Is location inside object?"