[movitz-cvs] CVS movitz/losp/muerte
ffjeld
ffjeld at common-lisp.net
Fri Mar 16 20:23:21 UTC 2007
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 at 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))
More information about the Movitz-cvs
mailing list