[movitz-cvs] CVS movitz/losp/muerte
ffjeld
ffjeld at common-lisp.net
Fri Mar 16 22:13:56 UTC 2007
Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv8233
Modified Files:
scavenge.lisp
Log Message:
Somewhat improved speed of map-header-vals.
--- /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/03/16 21:17:55 1.58
+++ /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/03/16 22:13:55 1.59
@@ -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.58 2007/03/16 21:17:55 ffjeld Exp $
+;;;; $Id: scavenge.lisp,v 1.59 2007/03/16 22:13:55 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -55,7 +55,7 @@
(declare (ignorable x))
#+ignore `(setf *scan-last* ,x)))
(do ((verbose *map-header-vals-verbose*)
- (*scan-last* nil) ; Last scanned object, for debugging.
+ #+ignore (*scan-last* nil) ; Last scanned object, for debugging.
(scan start-location (1+ scan)))
((>= scan end-location))
(declare (fixnum scan))
@@ -146,57 +146,45 @@
;; lambda-list and name
(map-header-vals function (incf scan) (incf scan 2))
;; Jumpers
- (let ((num-jumpers (memref scan 0 :type :unsigned-byte14))
- #+ignore (num-constants (memref scan 2 :type :unsigned-byte16)))
+ (let ((num-jumpers (memref scan 0 :type :unsigned-byte14)))
(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-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :bit))
- (assert (evenp scan) ()
- "Scanned bit-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+ (* 2 (truncate (+ 63 len) 64))))))
((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)))
+ (assert (evenp scan) ()
+ "Scanned basic-vector-header ~S at odd location #x~X." x scan)
+ (cond
+ ((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)))
+ (let ((len (memref scan 4)))
+ (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))
+ (let ((len (memref scan 0 :index 1)))
+ (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))
+ (let ((len (memref scan 4)))
+ (record-scan (%word-offset scan #.(movitz:tag :other)))
+ (incf scan (1+ (logand (1+ len) -2)))))
+ ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :bit))
+ (let ((len (memref scan 4)))
+ (record-scan (%word-offset scan #.(movitz:tag :other)))
+ (incf scan (1+ (* 2 (truncate (+ 63 len) 64))))))
+ ((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))))
+ (t (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)
@@ -205,13 +193,12 @@
;; (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))))))))))
+ (let* ((old (memref scan 0))
+ (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