X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-introspect%2Ftest-driver.lisp;h=c38d9f576a8dc62a22f700de68a2e9e6c7c1f24e;hb=95d19447c10434753c2168ac943152fd5e3ded3d;hp=2e82fe0f033e5a471780aa61c5f18bffc9d4d833;hpb=f94b4d8de83c02854d274a9b5be923f4f60c5b02;p=sbcl.git

diff --git a/contrib/sb-introspect/test-driver.lisp b/contrib/sb-introspect/test-driver.lisp
index 2e82fe0..c38d9f5 100644
--- a/contrib/sb-introspect/test-driver.lisp
+++ b/contrib/sb-introspect/test-driver.lisp
@@ -145,5 +145,66 @@
 
 (load (merge-pathnames "xref-test.lisp" *load-pathname*))
 
+;;; Test allocation-information
+
+(defun tai (x kind info)
+  (multiple-value-bind (kind2 info2) (sb-introspect:allocation-information x)
+    (unless (eq kind kind2)
+      (error "wanted ~S, got ~S" kind kind2))
+    (assert (equal info info2))))
+
+(tai nil :heap '(:space :static))
+(tai t :heap '(:space :static))
+(tai 42 :immediate nil)
+(tai #'cons :heap
+     #+(and (not ppc) gencgc)
+     ;; FIXME: This is the canonical GENCGC result, the one below for PPC is
+     ;; what we get there, but :LARGE T doesn't seem right. Figure out what's
+     ;; going on.
+     '(:space :dynamic :generation 6 :write-protected t :pinned nil :large nil)
+     #+(and ppc gencgc)
+     '(:space :dynamic :generation 6 :write-protected t :pinned nil :large t)
+     ;; FIXME: Figure out what's the right cheney-result, and which platforms
+     ;; return something else. The SPARC version here is what we get there,
+     ;; but quite possibly that is the result on all non-GENCGC platforms.
+     #+(and sparc (not gencgc))
+     '(:space :read-only)
+     #+(and (not sparc) (not gencgc))
+     '(:space :dynamic))
+#+sb-thread
+(let ((x (list 1 2 3)))
+  (declare (dynamic-extent x))
+  (tai x :stack sb-thread:*current-thread*))
+#+sb-thread
+(progn
+  (defun thread-tai ()
+    (let ((x (list 1 2 3)))
+      (declare (dynamic-extent x))
+      (let ((child (sb-thread:make-thread
+                    (lambda ()
+                      (sb-introspect:allocation-information x)))))
+        (assert (equal (list :stack sb-thread:*current-thread*)
+                       (multiple-value-list (sb-thread:join-thread child)))))))
+  (thread-tai)
+  (defun thread-tai2 ()
+    (let* ((sem (sb-thread:make-semaphore))
+           (obj nil)
+           (child (sb-thread:make-thread
+                   (lambda ()
+                     (let ((x (list 1 2 3)))
+                       (declare (dynamic-extent x))
+                       (setf obj x)
+                       (sb-thread:wait-on-semaphore sem)))
+                   :name "child")))
+      (loop until obj)
+      (assert (equal (list :stack child)
+                     (multiple-value-list
+                      (sb-introspect:allocation-information obj))))
+      (sb-thread:signal-semaphore sem)
+      (sb-thread:join-thread child)
+      nil))
+  (thread-tai2))
+
 ;;;; Unix success convention for exit codes
 (sb-ext:quit :unix-status 0)
+