Index: /branches/working-0711/ccl/library/core-files.lisp =================================================================== --- /branches/working-0711/ccl/library/core-files.lisp (revision 13475) +++ /branches/working-0711/ccl/library/core-files.lisp (revision 13476) @@ -36,5 +36,5 @@ 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,7 +42,7 @@ 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,4 +79,5 @@ ) + (defmethod print-object :around ((core core-info) (stream t)) (let ((*print-array* nil) @@ -121,12 +122,13 @@ +(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,4 +240,8 @@ (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,4 +492,18 @@ ;; 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,13 +511,6 @@ (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,8 +664,35 @@ (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,6 +712,8 @@ (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,4 +939,8 @@ 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,15 +1058,18 @@ (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,5 +1079,5 @@ (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,5 +1179,10 @@ (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,5 +1212,12 @@ 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,2 +1395,3 @@ ) ; :x8664-target +