Index: /branches/working-0711/ccl/library/core-files.lisp =================================================================== --- /branches/working-0711/ccl/library/core-files.lisp (revision 13460) +++ /branches/working-0711/ccl/library/core-files.lisp (revision 13461) @@ -110,5 +110,5 @@ (: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,6 +167,7 @@ (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,5 +177,5 @@ 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,11 +194,35 @@ (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,23 +381,32 @@ (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,5 +532,7 @@ (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,9 +613,12 @@ (defmethod print-object ((obj unresolved-address) stream) (let* ((address (unresolved-address-address obj))) - (format stream "#" - (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 "#" address) + (format stream "#" + (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,5 +636,6 @@ ((< (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,7 +1015,13 @@ (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)