Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv21201

Modified Files: scavenge.lisp Log Message: Remove rather useless restart in the inner loop of map-header-vals. This speeds up GC quite a bit.

--- /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2006/01/07 21:40:12 1.55 +++ /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/03/16 20:23:21 1.56 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.55 2006/01/07 21:40:12 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.56 2007/03/16 20:23:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -59,73 +59,71 @@ (scan start-location (1+ scan))) ((>= scan end-location)) (declare (fixnum scan)) - (with-simple-restart (continue-map-header-vals - "Continue map-header-vals at location ~S." (1+ scan)) - (let ((x (memref scan 0 :type :unsigned-byte16)) - (x2 (memref scan 1 :type :unsigned-byte16))) - (when verbose - (format *terminal-io* " [at ~S: ~S]" scan x)) - (cond - ((let ((tag (ldb (byte 3 0) x))) - (or (= tag #.(movitz:tag :null)) - (= tag #.(movitz:tag :even-fixnum)) - (= tag #.(movitz:tag :odd-fixnum)) - (scavenge-typep x :character)))) - ((or (and (= 0 x2) (= 2 x)) - (and (= #xffff x2) (= #xfffe x)) - (and (= #x7fff x2) (= #xffff x)))) - ((scavenge-typep x :illegal) - (error "Illegal word ~S at ~S." x scan)) - ((scavenge-typep x :bignum) - (assert (evenp scan) () - "Scanned bignum-header ~S at odd location #x~X." x scan) - ;; Just skip the bigits - (let* ((bigits (memref scan 0 :index 1 :type :unsigned-byte14)) - (delta (logior bigits 1))) - (record-scan (%word-offset scan #.(movitz:tag :other))) - (incf scan delta))) - ((scavenge-typep x :defstruct) - (assert (evenp scan) () - "Scanned struct-header ~S at odd location #x~X." x scan) - (record-scan (%word-offset scan #.(movitz:tag :other)))) - ((scavenge-typep x :run-time-context) - (assert (evenp scan) () - "Scanned run-time-context-header ~S at odd location #x~X." - (memref scan 0 :type :unsigned-byte32) scan) - (incf scan) - (let ((non-lispvals #.(cl:truncate (cl:+ -4 (bt:slot-offset 'movitz::movitz-run-time-context - 'movitz::pointer-start) - (movitz::image-nil-word movitz:*image*)) - 4)) - (end (+ scan #.(movitz::movitz-type-word-size 'movitz::movitz-run-time-context)))) - (incf scan non-lispvals) - (map-lisp-vals function scan (1+ end)) - (setf scan end))) - ((scavenge-typep x :funobj) - (assert (evenp scan) () - "Scanned funobj-header ~S at odd location #x~X." - (memref scan 0 :type :unsigned-byte32) scan) - (record-scan (%word-offset scan #.(movitz:tag :other))) - ;; Process code-vector pointers specially.. - (let* ((old-code-vector (memref (incf scan) 0 :type :code-vector)) - (new-code-vector (map-instruction-pointer function scan old-code-vector))) - (cond + (let ((x (memref scan 0 :type :unsigned-byte16)) + (x2 (memref scan 1 :type :unsigned-byte16))) + (when verbose + (format *terminal-io* " [at ~S: ~S]" scan x)) + (cond + ((let ((tag (ldb (byte 3 0) x))) + (or (= tag #.(movitz:tag :null)) + (= tag #.(movitz:tag :even-fixnum)) + (= tag #.(movitz:tag :odd-fixnum)) + (scavenge-typep x :character)))) + ((or (and (= 0 x2) (= 2 x)) + (and (= #xffff x2) (= #xfffe x)) + (and (= #x7fff x2) (= #xffff x)))) + ((scavenge-typep x :illegal) + (error "Illegal word ~S at ~S." x scan)) + ((scavenge-typep x :bignum) + (assert (evenp scan) () + "Scanned bignum-header ~S at odd location #x~X." x scan) + ;; Just skip the bigits + (let* ((bigits (memref scan 0 :index 1 :type :unsigned-byte14)) + (delta (logior bigits 1))) + (record-scan (%word-offset scan #.(movitz:tag :other))) + (incf scan delta))) + ((scavenge-typep x :defstruct) + (assert (evenp scan) () + "Scanned struct-header ~S at odd location #x~X." x scan) + (record-scan (%word-offset scan #.(movitz:tag :other)))) + ((scavenge-typep x :run-time-context) + (assert (evenp scan) () + "Scanned run-time-context-header ~S at odd location #x~X." + (memref scan 0 :type :unsigned-byte32) scan) + (incf scan) + (let ((non-lispvals #.(cl:truncate (cl:+ -4 (bt:slot-offset 'movitz::movitz-run-time-context + 'movitz::pointer-start) + (movitz::image-nil-word movitz:*image*)) + 4)) + (end (+ scan #.(movitz::movitz-type-word-size 'movitz::movitz-run-time-context)))) + (incf scan non-lispvals) + (map-lisp-vals function scan (1+ end)) + (setf scan end))) + ((scavenge-typep x :funobj) + (assert (evenp scan) () + "Scanned funobj-header ~S at odd location #x~X." + (memref scan 0 :type :unsigned-byte32) scan) + (record-scan (%word-offset scan #.(movitz:tag :other))) + ;; Process code-vector pointers specially.. + (let* ((old-code-vector (memref (incf scan) 0 :type :code-vector)) + (new-code-vector (map-instruction-pointer function scan old-code-vector))) + (cond ((not (eq new-code-vector old-code-vector)) ;; Code-vector%1op (if (location-in-code-vector-p%unsafe old-code-vector (memref (incf scan) 0 :type :location)) (map-instruction-pointer function scan old-code-vector) - (map-instruction-pointer function scan)) + (map-instruction-pointer function scan)) ;; Code-vector%2op (if (location-in-code-vector-p%unsafe old-code-vector (memref (incf scan) 0 :type :location)) (map-instruction-pointer function scan old-code-vector) - (map-instruction-pointer function scan)) + (map-instruction-pointer function scan)) ;; Code-vector%3op (if (location-in-code-vector-p%unsafe old-code-vector (memref (incf scan) 0 :type :location)) (map-instruction-pointer function scan old-code-vector) - (map-instruction-pointer function scan)) + (map-instruction-pointer function scan)) ;; lambda-list and name (map-header-vals function (incf scan) (incf scan 2)) ;; Jumpers @@ -151,61 +149,61 @@ (let ((num-jumpers (memref scan 0 :type :unsigned-byte14)) #+ignore (num-constants (memref scan 2 :type :unsigned-byte16))) (incf scan num-jumpers)))))) - ((scavenge-typep x :infant-object) - (assert (evenp scan) () - "Scanned infant ~S at odd location #x~X." x scan) - (error "Scanning an infant object ~Z at ~S (end ~S)." x scan end-location)) - ((or (scavenge-wide-typep x :basic-vector - #.(bt:enum-value 'movitz:movitz-vector-element-type :u8)) - (scavenge-wide-typep x :basic-vector - #.(bt:enum-value 'movitz:movitz-vector-element-type :character)) - (scavenge-wide-typep x :basic-vector - #.(bt:enum-value 'movitz:movitz-vector-element-type :code))) - (assert (evenp scan) () - "Scanned u8-vector-header ~S at odd location #x~X." x scan) - (let ((len (memref scan 0 :index 1 :type :lisp))) - (check-type len positive-fixnum) - (record-scan (%word-offset scan #.(movitz:tag :other))) - (incf scan (1+ (* 2 (truncate (+ 7 len) 8)))))) - ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16)) - (assert (evenp scan) () - "Scanned u16-vector-header ~S at odd location #x~X." x scan) - (let ((len (memref scan 0 :index 1))) - (check-type len positive-fixnum) - (record-scan (%word-offset scan #.(movitz:tag :other))) - (incf scan (1+ (* 2 (truncate (+ 3 len) 4)))))) - ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32)) - (assert (evenp scan) () - "Scanned u32-vector-header ~S at odd location #x~X." x scan) - (let ((len (memref scan 4))) - (assert (typep len 'positive-fixnum) () - "Scanned basic-vector at ~S with illegal length ~S." scan len) - (record-scan (%word-offset scan #.(movitz:tag :other))) - (incf scan (1+ (logand (1+ len) -2))))) - ((scavenge-typep x :basic-vector) - (if (or (scavenge-wide-typep x :basic-vector - #.(bt:enum-value 'movitz:movitz-vector-element-type - :any-t)) - (scavenge-wide-typep x :basic-vector - #.(bt:enum-value 'movitz:movitz-vector-element-type - :indirects))) - (record-scan (%word-offset scan #.(movitz:tag :other))) - (error "Scanned unknown basic-vector-header ~S at location #x~X." x scan))) - ((and (eq x 3) (eq x2 0)) - (record-scan scan) - (incf scan) - (let ((delta (memref scan 0))) - (check-type delta positive-fixnum) - ;; (warn "at ~S skipping ~S to ~S." scan delta (+ scan delta)) - (incf scan delta))) - (t ;; (typep x 'pointer) - (let ((old (memref scan 0))) - (unless (eq old (load-global-constant new-unbound-value)) - (let ((new (funcall function old scan))) - (when verbose - (format *terminal-io* " [~Z => ~Z]" old new)) - (unless (eq old new) - (setf (memref scan 0) new))))))))))) + ((scavenge-typep x :infant-object) + (assert (evenp scan) () + "Scanned infant ~S at odd location #x~X." x scan) + (error "Scanning an infant object ~Z at ~S (end ~S)." x scan end-location)) + ((or (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type :u8)) + (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type :character)) + (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type :code))) + (assert (evenp scan) () + "Scanned u8-vector-header ~S at odd location #x~X." x scan) + (let ((len (memref scan 0 :index 1 :type :lisp))) + (check-type len positive-fixnum) + (record-scan (%word-offset scan #.(movitz:tag :other))) + (incf scan (1+ (* 2 (truncate (+ 7 len) 8)))))) + ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16)) + (assert (evenp scan) () + "Scanned u16-vector-header ~S at odd location #x~X." x scan) + (let ((len (memref scan 0 :index 1))) + (check-type len positive-fixnum) + (record-scan (%word-offset scan #.(movitz:tag :other))) + (incf scan (1+ (* 2 (truncate (+ 3 len) 4)))))) + ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32)) + (assert (evenp scan) () + "Scanned u32-vector-header ~S at odd location #x~X." x scan) + (let ((len (memref scan 4))) + (assert (typep len 'positive-fixnum) () + "Scanned basic-vector at ~S with illegal length ~S." scan len) + (record-scan (%word-offset scan #.(movitz:tag :other))) + (incf scan (1+ (logand (1+ len) -2))))) + ((scavenge-typep x :basic-vector) + (if (or (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type + :any-t)) + (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type + :indirects))) + (record-scan (%word-offset scan #.(movitz:tag :other))) + (error "Scanned unknown basic-vector-header ~S at location #x~X." x scan))) + ((and (eq x 3) (eq x2 0)) + (record-scan scan) + (incf scan) + (let ((delta (memref scan 0))) + (check-type delta positive-fixnum) + ;; (warn "at ~S skipping ~S to ~S." scan delta (+ scan delta)) + (incf scan delta))) + (t ;; (typep x 'pointer) + (let ((old (memref scan 0))) + (unless (eq old (load-global-constant new-unbound-value)) + (let ((new (funcall function old scan))) + (when verbose + (format *terminal-io* " [~Z => ~Z]" old new)) + (unless (eq old new) + (setf (memref scan 0) new)))))))))) (values))

(defun map-stack-vector (function stack start-frame &optional (map-region #'map-header-vals))