Changeset 13461

Timestamp:

Feb 24, 2010, 9:18:55 AM (15 years ago)

Author:

gz

Message:

make map-core-areas accept :area :tenured to only look at the tenured area. Also handle :dynamic specially so works even if areas have been renumbered since the core file was made.

make core-offset-for-address do bounds checking, signal an error if not in any known section. Catch that error and do something reasonable when printing or just looking up types.

File:

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

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

@@ -110 +110 @@
       (:mmap   (let ((mapped-vector (map-file-to-ivector pathname '(unsigned-byte 8))))
                  (multiple-value-bind (vector offset) (array-data-and-offset mapped-vector)
-                   (loop for data across sections do (incf (cdr data) offset))
+                   (loop for data across sections do (incf (cadr data) offset))
                    (setf (core-info-mapped-ivector core) mapped-vector)
                    (setf (core-info-raw-ivector core) vector)
@@ -167 +167 @@
                            (unless (eql size 0)
                              (list (list address filepos size)))))))
-           (sections (cons (list most-positive-fixnum 0 0) sections));; hack for loop below
            (sections (sort sections #'< :key #'car));; sort by address
+           (sections (let ((last (car (last sections))))  ;; hack for loop below
+                       (nconc sections (list (list (+ (car last) (caddr last) 1) 0 0)))))
            (sections (loop
                        with cur-address = -1
@@ -176 +177 @@
                        unless (or (= (+ cur-filepos (- address cur-address)) filepos)
                                   (= cur-address cur-end))
-                         collect (cons cur-address cur-filepos)
+                         collect (list* cur-address cur-filepos cur-end)
                        do (if (= (+ cur-filepos (- address cur-address)) filepos)
                             (setq cur-end (max (+ address size) cur-end))
@@ -193 +194 @@
          (ftype (function (integer) fixnum) core-offset-for-address))
 
+(define-condition invalid-core-address (simple-error) ())
+
+(declaim (inline core-section-for-address))
+(defun core-section-for-address (address)
+  (loop with sections = (core-info-sections (current-core))
+        with len fixnum = (length sections)
+        with low fixnum = -1
+        with high fixnum = len
+        do (let ((half (the fixnum (ash (%i+ high low) -1))))
+             (declare (fixnum half))
+             (when (eq half low)
+               (return (and (%i<= 0 half)
+                            (%i< half len)
+                            (let ((sect (%svref sections half)))
+                              (and (< address (%cddr (%svref sections half))) sect)))))
+             (let ((sect (%svref sections half)))
+               (if (%i<= (%car sect) address)
+                 (setq low half)
+                 (setq high half))))))
+
+(defun core-heap-address-p (address)
+  (core-section-for-address address))
+
 (defun core-offset-for-address (address)
-  ;; sections are sorted, so could do binary search if this became a bottleneck.
-  ;; (there are around 50 sections)
-  (or (loop for prev = nil then sect as sect across (core-info-sections (current-core))
-            do (when (< address (car sect))
-                 (return (and prev (+ (cdr prev) (- address (car prev)))))))
-      (error "Unknown core address x~x" address)))
+  (let ((sect (core-section-for-address address)))
+    (if sect
+      (+ (%cadr sect) (- address (%car sect)))
+      (error 'invalid-core-address
+             :format-control "Unknown core address x~x"
+             :format-arguments (list address)))))
+
 
 (defun core-stream-readb (s offset)
@@ -356 +381 @@
 
 (defun map-core-areas (function &key area)
-  (setq area (cond ((or (eq area t) (eq area nil)) nil)
-                   ((consp area) (mapcar #'heap-area-code area))
-                   (t (list (heap-area-code area)))))
-  (loop for area-ptr = (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ)
-          then (core-q area-ptr target::area.succ)
-        as code = (ash (core-q area-ptr target::area.code) (- target::fixnum-shift))
-        until (= code area-void)
-        do (when (and (<= area-readonly code)
-                      (<= code area-dynamic)
-                      (or (null area) (member code area))
-                      (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active)))
-             #+debug
-             (format t "~& AREA at x~x, type = ~a low = x~x active = x~x (size = x~x out of x~x)"
-                     area-ptr (core-area-name code)
-                     (core-q area-ptr target::area.low)
-                     (core-q area-ptr target::area.active)
-                     (- (core-q area-ptr target::area.active) (core-q area-ptr target::area.low))
-                     (- (core-q area-ptr target::area.high) (core-q area-ptr target::area.low)))
-             (map-core-area area-ptr function))))
+  (if (eq area :tenured)
+    (map-core-area (core-q (kernel-global-address 'tenured-area)) function)
+    (loop 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))))
+          for area-ptr = (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ)
+            then (core-q area-ptr target::area.succ)
+          as code = (ash (core-q area-ptr target::area.code) (- target::fixnum-shift))
+          until (= code area-void)
+          do (when (and (<= area-readonly code)
+                        (<= code area-dynamic)
+                        (or (null area) (member code area))
+                        (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active)))
+               #+debug
+               (format t "~& AREA at x~x, type = ~a low = x~x active = x~x (size = x~x out of x~x)"
+                       area-ptr (core-area-name code)
+                       (core-q area-ptr target::area.low)
+                       (core-q area-ptr target::area.active)
+                       (- (core-q area-ptr target::area.active) (core-q area-ptr target::area.low))
+                       (- (core-q area-ptr target::area.high) (core-q area-ptr target::area.low)))
+               (map-core-area area-ptr function)))))
 
 (defun map-core-area (area-ptr fun)
@@ -498 +532 @@
            (type-of (%%raw-obj obj)))
           ((eq (logand fulltag target::tagmask) target::tag-tra) 'tagged-return-address)
-          ((eq fulltag target::fulltag-misc) (core-uvtype obj))
+          ((eq fulltag target::fulltag-misc)
+           ;; (core-uvtype obj)
+           (handler-case (core-uvtype obj) (invalid-core-address () 'unmapped)))
           ((eq fulltag target::fulltag-symbol) 'symbol)
           ;; TODO: Could get hairier based on lfun-bits, but usually don't care.
@@ -577 +613 @@
 (defmethod print-object ((obj unresolved-address) stream)
   (let* ((address (unresolved-address-address obj)))
-    (format stream "#<Core ~A~@[[~d]~] #x~x >"
-            (or (ignore-errors (core-type-string (core-object-type-key address)))
-                (core-object-typecode-type address))
-            (and (core-uvector-p address) (core-uvsize address))
-            address)))
+    (if (and (core-uvector-p address)
+             (not (handler-case (core-uvheader address) (invalid-core-address () nil))))
+      (format stream "#<Unmapped #x~x >" address)
+      (format stream "#<Core ~A~@[[~d]~] #x~x >"
+              (or (ignore-errors (core-type-string (core-object-type-key address)))
+                  (core-object-typecode-type address))
+              (and (core-uvector-p address) (core-uvsize address))
+            address))))
 
 (defun copy-from-core (obj &key (depth 1))
@@ -597 +636 @@
           ((< (decf depth) 0)
            (make-unresolved-address :address obj))
-          ((%i<= target::fulltag-misc fulltag)
+          ((and (%i<= target::fulltag-misc fulltag)
+                (handler-case (core-uvheader obj) (invalid-core-address nil)))
            (or (and (core-uvtypep obj :package)
                     (find-package (core-package-name obj)))
@@ -975 +1015 @@
            (format stream ":"))
           (t (let ((pkgname (core-package-name package)))
-               (unless (string-equal pkgname "COMMON-LISP")
-                 (format stream "~a::" pkgname)))))
-    (format stream "~a" (core-symbol-name sym))))
+               (etypecase pkgname
+                 (unresolved-address (format stream "@~x::" (unresolved-address-address pkgname)))
+                 (string (unless (string-equal pkgname "COMMON-LISP")
+                           (format stream "~a::" pkgname)))))))
+    (let ((symname (core-symbol-name sym)))
+      (etypecase symname
+        (unresolved-address (format stream "@~x" (unresolved-address-address symname)))
+        (string (format stream "~a" symname)))))
+  (values))
 
 (defun core-lfun-bits (fun)