Index: /branches/working-0711/ccl/library/core-files.lisp =================================================================== --- /branches/working-0711/ccl/library/core-files.lisp (revision 13464) +++ /branches/working-0711/ccl/library/core-files.lisp (revision 13465) @@ -20,4 +20,13 @@ #+:linuxx8664-target (progn + + +(defconstant $image-nsections 7) +(defconstant $image-data-offset-64 9) +(defconstant $image-header-size 16) + +(defconstant $image-sect-code 0) +(defconstant $image-sect-size 4) +(defconstant $image-sect-header-size 8) (export '(open-core close-core @@ -61,7 +70,6 @@ sections ;; uses either stream or ivector, determined at runtime - stream - mapped-ivector - raw-ivector + streams + ivectors ;; caches symbol-ptrs @@ -87,13 +95,33 @@ (setq *current-core* nil) (when core - (when (core-info-stream core) - (close (core-info-stream core))) - (when (core-info-mapped-ivector core) - (unmap-ivector (core-info-mapped-ivector core))) + (map nil #'close (core-info-streams core)) + (map nil #'unmap-ivector (core-info-ivectors core)) t))) + +; +(defmacro area-loop (with ptrvar &body body) + (assert (eq with 'with)) + (let ((before (loop while (eq (car body) 'with) + nconc (list (pop body) (pop body) (pop body) (pop body))))) + `(loop ,@before + for ,ptrvar = (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ) + then (core-q ,ptrvar target::area.succ) + until (eq (core-q area-ptr target::area.code) (ash area-void target::fixnum-shift)) + ,@body))) + +(def-accessor-macros %svref + %core-sect.start-addr + %core-sect.offset + %core-sect.end-addr + %core-sect.ivector + %core-sect.stream) + +(defun make-core-sect (&key start end offset ivector stream) + (vector start offset end ivector stream)) + ;; 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 (method :mmap) (core-info nil)) +(defun open-core (pathname &key (image nil) (method :mmap) (core-info nil)) (when core-info (check-type core-info core-info)) (when *current-core* @@ -107,17 +135,28 @@ (setf (core-info-lfun-names-table-ptr core) nil) (setf (core-info-process-class core) nil) + (setf (core-info-ivectors core) nil) + (setf (core-info-streams core) nil) (ecase method (: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 (cadr data) offset)) - (setf (core-info-mapped-ivector core) mapped-vector) - (setf (core-info-raw-ivector core) vector) - (setf (core-info-stream core) nil)))) - (:stream (setf (core-info-stream core) (open pathname :element-type '(unsigned-byte 8)) - (core-info-mapped-ivector core) nil - (core-info-raw-ivector core) nil))) + (push mapped-vector (core-info-ivectors core)) + (loop for sect across sections + do (incf (%core-sect.offset sect) offset) + do (setf (%core-sect.ivector sect) vector))))) + (:stream (let ((stream (open pathname :element-type '(unsigned-byte 8) + :sharing :lock))) + (push stream (core-info-streams core)) + (loop for sect across sections do (setf (%core-sect.stream sect) stream))))) (setq *current-core* core)) ;;(unless (every (lambda (sect) (fixnump (car sect))) (core-info-sections (current-core))) ;; (error "Non-fixnum addresses not supported")) + (when (and image + (area-loop with area-ptr + thereis (and (eq (core-q area-ptr target::area.code) + (ash area-readonly target::fixnum-shift)) + (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active)) + (not (core-section-for-address (core-q area-ptr target::area.low)))))) + ;; Have a missing readonly section, and an image file that might contain it. + (add-core-sections-from-image image)) pathname) @@ -177,5 +216,8 @@ unless (or (= (+ cur-filepos (- address cur-address)) filepos) (= cur-address cur-end)) - collect (list* cur-address cur-filepos cur-end) + collect (make-core-sect + :start cur-address + :end cur-end + :offset cur-filepos) do (if (= (+ cur-filepos (- address cur-address)) filepos) (setq cur-end (max (+ address size) cur-end)) @@ -186,4 +228,61 @@ +(defun add-core-sections-from-image (pathname) + (with-open-file (header-stream pathname :element-type '(signed-byte 32)) + (labels ((read-at (&optional pos) + (when pos (file-position header-stream pos)) + (read-byte header-stream)) + (readn (pos) (+ (logand #xFFFFFFFF (read-at pos)) (ash (read-at) 32)))) + (let* ((sig '(#x4F70656E #x4D434C49 #x6D616765 #x46696C65)) + (end (file-length header-stream)) + (page-mask (1- *host-page-size*)) + (header (+ end (/ (read-at (1- end)) 4)))) + (assert (and (integerp header) (< header end) (<= 0 header))) + (file-position header-stream header) + (assert (loop for s in sig always (eql s (read-at)))) + (let* ((nsections (read-at (+ header $image-nsections))) + (offset + #+64-bit-host (/ (+ (ash (read-at (+ header $image-data-offset-64)) 32) + (logand #xFFFFFFFF (read-at))) 4) + #-64-bit-host 0) + (sections (loop repeat nsections + for pos upfrom (+ header $image-header-size) by $image-sect-header-size + for epos = (* 4 (+ header $image-header-size + (* nsections $image-sect-header-size) + offset)) + then (+ fpos mem-size) + as fpos = (logandc2 (+ epos page-mask) page-mask) + as mem-size = (readn (+ pos $image-sect-size)) + when (eq (readn (+ pos $image-sect-code)) + (ash area-readonly target::fixnum-shift)) + collect (cons fpos mem-size))) + (new (area-loop with area-ptr + when (and (eq (core-q area-ptr target::area.code) + (ash area-readonly target::fixnum-shift)) + (< (core-q area-ptr target::area.low) + (core-q area-ptr target::area.active)) + (not (core-section-for-address (core-q area-ptr target::area.low)))) + collect (let* ((size (- (core-q area-ptr target::area.active) + (core-q area-ptr target::area.low))) + (matches (remove size sections :key 'cdr :test-not 'eql))) + + ;; **** should just do nothing if not found + (assert (eql (length matches) 1)) + (make-core-sect + :start (core-q area-ptr target::area.low) + :end (core-q area-ptr target::area.active) + :offset (caar matches))))) + (image-stream (open pathname :element-type '(unsigned-byte 8) :sharing :lock))) + (unwind-protect + (let ((core (current-core))) + (setf (core-info-sections core) + (sort (concatenate 'vector new (core-info-sections core)) + #'< :key (lambda (s) (%core-sect.start-addr s)))) + (push image-stream (core-info-streams core)) + (loop for s in new do (setf (%core-sect.stream s) image-stream)) + (setq image-stream nil)) + (when image-stream (close image-stream :abort t)))))))) + + (declaim (inline core-ivector-readb core-ivector-readw core-ivector-readl core-ivector-readq core-stream-readb core-stream-readw core-stream-readl core-stream-readq)) @@ -192,7 +291,9 @@ (ftype (function (t t) (unsigned-byte 32)) core-ivector-readl core-stream-readl) (ftype (function (t t) (unsigned-byte 64)) core-ivector-readq core-stream-readq) - (ftype (function (integer) fixnum) core-offset-for-address)) - -(define-condition invalid-core-address (simple-error) ()) + (ftype (function (simple-vector) fixnum) core-section-for-address)) + +(define-condition invalid-core-address (simple-error) + () + (:default-initargs :format-control "Unknown core address x~x")) (declaim (inline core-section-for-address)) @@ -208,7 +309,7 @@ (%i< half len) (let ((sect (%svref sections half))) - (and (< address (%cddr (%svref sections half))) sect))))) + (and (< address (%core-sect.end-addr (%svref sections half))) sect))))) (let ((sect (%svref sections half))) - (if (%i<= (%car sect) address) + (if (%i<= (%core-sect.start-addr sect) address) (setq low half) (setq high half)))))) @@ -216,12 +317,4 @@ (defun core-heap-address-p (address) (core-section-for-address address)) - -(defun core-offset-for-address (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))))) @@ -266,37 +359,50 @@ (defun core-q (address &optional (offset 0)) (declare (optimize (speed 3) (safety 0))) - (let* ((core (current-core)) - (ivector (core-info-raw-ivector core))) - (declare (type core-info core)) + (incf address offset) + (let* ((sect (or (core-section-for-address address) + (error 'invalid-core-address + :format-arguments (list address)))) + (ivector (%core-sect.ivector sect)) + (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect))))) (if ivector - (core-ivector-readq ivector (core-offset-for-address (+ address offset))) - (core-stream-readq (core-info-stream core) (core-offset-for-address (+ address offset)))))) + (core-ivector-readq ivector pos) + (core-stream-readq (%core-sect.stream sect) pos)))) + (defun core-l (address &optional (offset 0)) (declare (optimize (speed 3) (safety 0))) - (let* ((core (current-core)) - (ivector (core-info-raw-ivector core))) - (declare (type core-info core)) + (incf address offset) + (let* ((sect (or (core-section-for-address address) + (error 'invalid-core-address + :format-arguments (list address)))) + (ivector (%core-sect.ivector sect)) + (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect))))) (if ivector - (core-ivector-readl ivector (core-offset-for-address (+ address offset))) - (core-stream-readl (core-info-stream core) (core-offset-for-address (+ address offset)))))) + (core-ivector-readl ivector pos) + (core-stream-readl (%core-sect.stream sect) pos)))) (defun core-w (address &optional (offset 0)) (declare (optimize (speed 3) (safety 0))) - (let* ((core (current-core)) - (ivector (core-info-raw-ivector core))) - (declare (type core-info core)) + (incf address offset) + (let* ((sect (or (core-section-for-address address) + (error 'invalid-core-address + :format-arguments (list address)))) + (ivector (%core-sect.ivector sect)) + (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect))))) (if ivector - (core-ivector-readw ivector (core-offset-for-address (+ address offset))) - (core-stream-readw (core-info-stream core) (core-offset-for-address (+ address offset)))))) + (core-ivector-readw ivector pos) + (core-stream-readw (%core-sect.stream sect) pos)))) (defun core-b (address &optional (offset 0)) (declare (optimize (speed 3) (safety 0))) - (let* ((core (current-core)) - (ivector (core-info-raw-ivector core))) - (declare (type core-info core)) + (incf address offset) + (let* ((sect (or (core-section-for-address address) + (error 'invalid-core-address + :format-arguments (list address)))) + (ivector (%core-sect.ivector sect)) + (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect))))) (if ivector - (core-ivector-readb ivector (core-offset-for-address (+ address offset))) - (core-stream-readb (core-info-stream core) (core-offset-for-address (+ address offset)))))) + (core-ivector-readb ivector pos) + (core-stream-readb (%core-sect.stream sect) pos)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -383,30 +489,28 @@ (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))))) + (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)))) + as code = (ash (core-q area-ptr target::area.code) (- target::fixnum-shift)) + 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) Index: /branches/working-0711/ccl/library/dominance.lisp =================================================================== --- /branches/working-0711/ccl/library/dominance.lisp (revision 13464) +++ /branches/working-0711/ccl/library/dominance.lisp (revision 13465) @@ -48,7 +48,7 @@ ) -(defun open-core-graph (pathname) +(defun open-core-graph (pathname &key image) (let ((cg (%cons-cg))) - (open-core pathname :core-info cg) + (open-core pathname :core-info cg :image image) (let ((area-ptr (core-q (kernel-global-address 'tenured-area)))) (setf (cg.heap-base cg) (core-q area-ptr target::area.low))