Changeset 13465

Timestamp:

Feb 26, 2010, 12:26:02 PM (15 years ago)

Author:

gz

Message:

add :image arg to core-open specify an image file, use it to load any readonly areas missing from the core file (which is usually where class and packae names live)

Location:

branches/working-0711/ccl/library

Files:

• core-files.lisp (modified) (11 diffs)
• dominance.lisp (modified) (1 diff)

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

@@ -20 +20 @@
 #+: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 +70 @@
   sections
   ;; uses either stream or ivector, determined at runtime
-  stream
-  mapped-ivector
-  raw-ivector
+  streams
+  ivectors
   ;; caches
   symbol-ptrs
@@ -87 +95 @@
     (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 +135 @@
     (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 +216 @@
                        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 +228 @@
 
 
+(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 +291 @@
          (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 +309 @@
                             (%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 +317 @@
 (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 +359 @@
 (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 +489 @@
   (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)

branches/working-0711/ccl/library/dominance.lisp

@@ -48 +48 @@
   )
 
-(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))