Changeset 13476

Timestamp:

Mar 3, 2010, 12:44:08 PM (15 years ago)

Author:

gz

Message:

Core file support improvements:

Added core-symbol-plist, core-nth-immediate, core-function-type.
Make core-object-type-key use core-function-type, so now different classes of function are reported separately by core-heap-utilities.
Check that :image arg to open-core is actually an image file.
Make open-core indirect thru *core-info-class* to make the core-info
Add explicit knowledge about recent area renumbering so can examine core files that predate the change.
Handle printing eql specializers when printing methods
Make sure core-lfun-bits always returns a fixnum.

File:

• branches/working-0711/ccl/library/core-files.lisp (modified) (15 diffs)

branches/working-0711/ccl/library/core-files.lisp

@@ -36 +36 @@
           core-uvtype core-uvtypep core-uvref core-uvsize
           core-car core-cdr core-object-typecode-type
-          core-istruct-type core-struct-type core-instance-type
+          core-istruct-type core-struct-type core-instance-type core-function-type
           core-object-type-key  core-type-string
           copy-from-core core-list
@@ -42 +42 @@
           core-package-names core-package-name
           core-map-symbols
-          core-symbol-name core-symbol-value core-symbol-package
+          core-symbol-name core-symbol-value core-symbol-package core-symbol-plist
           core-gethash core-hash-table-count
-          core-lfun-name core-lfun-bits
+          core-lfun-name core-lfun-bits core-nth-immediate
           core-find-class
           core-instance-class
@@ -79 +79 @@
   )
 
+
 (defmethod print-object :around ((core core-info) (stream t))
   (let ((*print-array* nil)
@@ -121 +122 @@
 
 
+(defvar *core-info-class* 'core-info)
+
 ;; TODO: after load sections, check if highest heap address is a fixnum, and
 ;; arrange to use fixnum-only versions of the reading functions.
 (defun open-core (pathname &key (image nil) (method :mmap) (core-info nil))
-  (when core-info (check-type core-info core-info))
   (when *current-core*
     (close-core))
   (let* ((sections (read-sections pathname))
-         (core (or core-info (make-core-info))))
+         (core (require-type (or core-info (make-instance *core-info-class*)) 'core-info)))
     (setf (core-info-pathname core) pathname)
     (setf (core-info-sections core) sections)
@@ -238 +240 @@
              (page-mask (1- *host-page-size*))
              (header (+ end (/ (read-at (1- end)) 4))))
+        (unless (progn
+                  (file-position header-stream (- end 4))
+                  (loop repeat 3 as s in sig always (eql s (read-at))))
+          (error "~s is not a ccl image file" pathname))
         (assert (and (integerp header) (< header end) (<= 0 header)))
         (file-position header-stream header)
@@ -486 +492 @@
 ;;  Core heap
 
+
+(defun core-heap-area-code (area)
+  (let ((code (heap-area-code area))
+        (dynamic (ash (core-q (core-q (core-q (kernel-global-address 'all-areas))
+                                      target::area.succ)
+                              target::area.code)
+                      (- target::fixnum-shift))))
+    (if (or (fixnump area)
+            (eq dynamic area-dynamic)
+            ;; account for watched area having been inserted
+            (<= code area-watched))
+      code
+      (1- code))))
+
 (defun map-core-areas (function &key area)
   (if (eq area :tenured)
@@ -491 +511 @@
     (area-loop with area-ptr
                with area = (cond ((or (eq area t) (eq area nil)) nil)
-                                 ;; Special-case dynamic to work even if areas have been renumbered:
-                                 ;;  assume the first area is always dynamic, use its code.
-                                 ((eq area :dynamic)
-                                  (list (ash (core-q (core-q (core-q (kernel-global-address 'all-areas))
-                                                             target::area.succ)
-                                                     target::area.code)
-                                             (- target::fixnum-shift))))
-                                 ((consp area) (mapcar #'heap-area-code area))
-                                 (t (list (heap-area-code area))))
+                                 ((consp area) (mapcar #'core-heap-area-code area))
+                                 (t (list (core-heap-area-code area))))
                as code = (ash (core-q area-ptr target::area.code) (- target::fixnum-shift))
                do (when (and (<= area-readonly code)
@@ -651 +664 @@
   (let ((type (core-object-typecode-type obj)))
     (case type
+      (function (core-function-type obj))
       (internal-structure (core-istruct-type obj))
       (structure (core-struct-type obj))
       (instance (core-instance-type obj))
       (t type))))
+
+(defun core-function-type (obj)
+  (and (core-uvtypep obj :function)
+       (let ((bits (core-lfun-bits obj)))
+         (declare (fixnum bits))
+         (or (if (logbitp $lfbits-trampoline-bit bits)
+               (let* ((inner-fn (core-closure-function obj))
+                      (inner-bits (core-lfun-bits inner-fn)))
+                 (if (neq inner-fn obj)
+                   (if (logbitp $lfbits-method-bit inner-bits)
+                     'compiled-lexical-closure
+                     (unless (logbitp $lfbits-gfn-bit inner-bits)
+                       (if (logbitp $lfbits-cm-bit inner-bits)
+                         'combined-method
+                         'compiled-lexical-closure)))
+                   'compiled-lexical-closure))
+               (if (logbitp  $lfbits-method-bit bits)
+                 'method-function
+                 (unless (logbitp $lfbits-gfn-bit bits)
+                   (if (logbitp $lfbits-cm-bit bits)
+                     'combined-method
+                     'function))))
+             (core-class-name
+              (core-uvref
+               (core-nth-immediate obj gf.instance.class-wrapper)
+               %wrapper-class))))))
 
 (defun core-type-string (object-type)
@@ -672 +712 @@
 (defun core-instance-type (obj)
   (and (core-uvtypep obj :instance)
-       (core-uvref (core-uvref (core-instance-class obj) instance.slots) %class.name)))
-
+       (core-class-name (core-instance-class obj))))
+
+(defun core-class-name (class)
+  (core-uvref (core-uvref class instance.slots) %class.name))
 
 (defun core-object-type-and-size (obj)
@@ -897 +939 @@
         cell))))
 
+(defun core-symbol-plist (obj)
+  (when (setq obj (core-symptr obj))
+    (core-cdr (core-q obj target::symbol.plist))))
+
 (defun core-all-packages-ptr ()
   (core-symbol-value (nil-relative-symbol-address '%all-packages%)))
@@ -1012 +1058 @@
             (core-symbol-value (core-find-symbol '*lfun-names*)))))
 
+(defun core-nth-immediate (fn i)
+  (assert (core-uvtypep fn :function))
+  (let ((addr (+ (logandc2 fn target::fulltagmask) target::node-size)))
+    (core-q addr (%ilsl target::word-shift (+ (core-l addr) i -1)))))
+
 (defun core-closure-function (fun)
   (while (and (core-functionp fun)
               (logbitp $lfbits-trampoline-bit (core-lfun-bits fun)))
-    (let* ((addr (+ (logandc2 fun target::fulltagmask) target::node-size)))
-      (setq fun (core-q addr (%ilsl target::word-shift (core-l addr))))
-      (when (core-uvtypep fun :simple-vector)
-        (setq fun (core-uvref fun 0)))
-      #+gz (assert (core-functionp fun))))
+    (setq fun (core-nth-immediate fun 1))
+    (when (core-uvtypep fun :simple-vector)
+      (setq fun (core-uvref fun 0)))
+    #+gz (assert (core-functionp fun)))
   fun)
 
-    
 (defun core-lfun-name (fn)
   (assert (core-functionp fn))
@@ -1030 +1079 @@
                       (name (if (and (logbitp $lfbits-gfn-bit lfbits)
                                      (not (logbitp $lfbits-method-bit lfbits)))
-                                (core-uvref (core-uvref fn gf.slots) sgf.name)
+                                (core-uvref (core-nth-immediate fn gf.slots) sgf.name)
                                 (unless (logbitp $lfbits-noname-bit lfbits)
                                   (core-uvref fn (- (core-uvsize fn) 2))))))
@@ -1130 +1179 @@
 
 (defun core-lfun-bits (fun)
-  (ash (core-uvref fun (1- (core-uvsize fun))) (- target::fixnum-shift)))
+  (let ((unsigned (core-uvref fun (1- (core-uvsize fun)))))
+    (ash (if (logbitp (1- (* target::node-size 8)) unsigned)
+           (logior (ash -1 (* target::node-size 8)) unsigned)
+           unsigned)
+         (- target::fixnum-shift))))
+
 
 (defun core-print-function (fun stream)
@@ -1158 +1212 @@
                    do (let ((spec (core-car method-specializers)))
                         (if (core-uvtypep spec :instance)
-                          (core-print (core-uvref (core-uvref spec instance.slots) %class.name) stream)
+                          (let ((slots (core-uvref spec instance.slots)))
+                            ;; specializer is either a class or a ccl::eql-specializer
+                            (if (eql (core-uvsize slots) 3)
+                              (progn
+                                (format stream "(EQL ")
+                                (core-print (core-uvref slots 2) stream)
+                                (format stream ")"))
+                              (core-print (core-uvref slots %class.name) stream)))
                           (core-print spec stream)))
                    do (setq method-specializers (core-cdr method-specializers)))
@@ -1334 +1395 @@
 
 )                             ; :x8664-target
+