July 2004 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp
by Frode Vatvedt Fjeld 20 Jul '04

20 Jul '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv16897 Modified Files: los0-gc.lisp Log Message: Various tweaks to los0-gc. * Bind *standard-output* to *terminal-io* during GC * Perform some rather extensive consistency checks before/after GC. This takes some time, but is probably helpful at this stage. Date: Tue Jul 20 16:47:50 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.29 movitz/losp/los0-gc.lisp:1.30 --- movitz/losp/los0-gc.lisp:1.29 Fri Jul 16 18:56:52 2004 +++ movitz/losp/los0-gc.lisp Tue Jul 20 16:47:50 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.29 2004/07/17 01:56:52 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.30 2004/07/20 23:47:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -237,6 +237,7 @@ (:ret)))) (do-it))) +(defvar *gc-stack*) (defun install-los0-consing (&key (context (current-run-time-context)) (kb-size 1024) @@ -247,19 +248,20 @@ (setf (exception-handler 113) (lambda (exception interrupt-frame) (declare (ignore exception interrupt-frame)) - (when *gc-running* - (let ((muerte::*error-no-condition-for-debugger* t)) - (error "Recursive GC triggered."))) - (let ((*gc-running t)) - (unless *gc-quiet* - (format t "~&;; GC.. ")) - (stop-and-copy) - (loop ; This is a nice opportunity to poll the keyboard.. - (case (muerte.x86-pc.keyboard:poll-char) - ((#\esc) - (break "Los0 GC keyboard poll.")) - ((nil) - (return))))))) + (let ((*standard-output* *terminal-io*)) + (when *gc-running* + (let ((muerte::*error-no-condition-for-debugger* t)) + (error "Recursive GC triggered."))) + (let ((*gc-running t)) + (unless *gc-quiet* + (format t "~&;; GC.. ")) + (stop-and-copy) + (loop ; This is a nice opportunity to poll the keyboard.. + (case (muerte.x86-pc.keyboard:poll-char) + ((#\esc) + (break "Los0 GC keyboard poll.")) + ((nil) + (return)))))))) (let* ((actual-duo-space (or duo-space (allocate-duo-space (* kb-size #x100)))) (last-location (object-location (cons 1 2)))) @@ -331,7 +333,8 @@ (initialize-space oldspace) (values)))) -(defparameter *x* #500()) + +(defparameter *x* #4000()) ; Have this in static space. (defun stop-and-copy (&optional evacuator) (setf (fill-pointer *x*) 0) @@ -356,7 +359,7 @@ (cond ((not (object-in-space-p oldspace x)) x) - #+ignore ((typep x 'muerte::bignum) + #+ignore ((typep x 'bignum) (let ((fwi (position (object-location x) *x* :test #'eq))) (if fwi (muerte::%word-offset (aref *x* (1+ fwi)) 6) @@ -371,10 +374,14 @@ (object-tag x))) forwarded-x) (let ((forward-x (shallow-copy x))) - (when (typep x 'muerte::bignum) - (assert (= x forward-x))) + (let ((a *x*)) + (when (typep x 'muerte::pointer) + (vector-push (%object-lispval x) a) + (vector-push (memref (object-location x) 0 0 :unsigned-byte32) a) + (assert (vector-push (%object-lispval forward-x) a)))) (setf (memref (object-location x) 0 0 :lisp) forward-x) forward-x))))))))) + (setf *gc-stack* (muerte::copy-control-stack)) ;; Scavenge roots (dolist (range muerte::%memory-map-roots%) (map-heap-words evacuator (car range) (cdr range))) @@ -389,15 +396,31 @@ (+ newspace-location (space-fresh-pointer newspace))) (setf scan-pointer fresh-pointer)) - #+ignore (dotimes (i (truncate (length *x*) 2)) - (let ((x (muerte::%word-offset (aref *x* (* i 2)) 6)) - (y (muerte::%word-offset (aref *x* (1+ (* i 2))) 6))) - (assert (and (object-in-space-p newspace y) - (object-in-space-p oldspace x) - (or (typep x 'muerte::std-instance) - (equalp x y))) - () - "Fail: i=~D, x: ~S/~Z, y: ~S/~Z, o: ~Z, n: ~Z" i x x y y oldspace newspace))) + ;; Consistency check.. + (let ((a *x*)) + ;; First, restore the state of old-space + (do ((i 0 (+ i 3))) + ((>= i (length a))) + (let ((old (%lispval-object (aref a i))) + (old-class (aref a (+ i 1)))) + (setf (memref (object-location old) 0 0 :unsigned-byte32) old-class))) + ;; Then, check that each migrated object is equalp to its new self. + (do ((i 0 (+ i 3))) + ((>= i (length a))) + (let ((old (%lispval-object (aref a i))) + (new (%lispval-object (aref a (+ i 2))))) + (unless (and (object-in-space-p newspace new) + (object-in-space-p oldspace old) + (objects-equalp old new)) + (let ((*old* old) + (*new* new) + (*old-class* (aref a (+ i 1)))) + (declare (special *old* *new* *old-class*)) + (error "GC consistency check failed: +old object: ~Z: ~S +new object: ~Z: ~S +oldspace: ~Z, newspace: ~Z, i: ~D" + old old new new oldspace newspace i)))))) ;; GC completed, oldspace is evacuated. (unless *gc-quiet*

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp
by Frode Vatvedt Fjeld 20 Jul '04

20 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5409 Modified Files: scavenge.lisp Log Message: In map-stack-words, don't be so fascist about detecting an interrupted primitive-function. That is, if we detect that the call-site calls /some/ primitive-function, then it's ok. Previously we also checked that the call-site matched the exact pf that was interrupted, but then what if the pf tail-called another pf? Date: Tue Jul 20 07:13:36 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.23 movitz/losp/muerte/scavenge.lisp:1.24 --- movitz/losp/muerte/scavenge.lisp:1.23 Tue Jul 20 06:13:41 2004 +++ movitz/losp/muerte/scavenge.lisp Tue Jul 20 07:13:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.23 2004/07/20 13:13:41 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.24 2004/07/20 14:13:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -168,16 +168,29 @@ interrupted-eip-loc) ;; The simple case: The interruptee matches interrupted EIP (map-heap-words function interrupted-esp frame) - (let ((primitive-function-vector + (let ((primitive-function (stack-frame-primitive-funcall interrupted-funobj interrupted-esp interrupted-eip-loc))) - (if primitive-function-vector + (if (not primitive-function) + (error "Don't know how to scavenge across PF interrupt frame at ~S." + interrupt-frame) + (let ((forwarded-pf (funcall function primitive-function nil))) ;; Next simplest case: The interruptee was in a primitive-function, ;; with the return-address at top of stack. - (map-heap-words function (1+ interrupted-esp) frame) - (error "Don't know how to scavenge across interrupt frame at ~S." - interrupt-frame))))))) + (unless (eq primitive-function forwarded-pf) + ;; The PF's vector has migrated. + (let* ((interrupted-eip + (interrupt-frame-ref :eip :unsigned-byte32 0 :unsigned-byte32)) + (offset (- interrupted-eip (%object-lispval primitive-function)))) + (break "Active PF moved. PF: ~Z, fwPF: ~Z, offset: ~D, PFlen ~D." + primitive-function + forwarded-pf + offset + (+ 8 (length forwarded-pf))) + (setf (memref interrupted-esp 0 0 :unsigned-byte32) + (+ offset (%object-lispval forwarded-pf))))) + (map-heap-words function (1+ interrupted-esp) frame)))))))) (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj))))) (values)) @@ -189,6 +202,7 @@ (defun stack-frame-primitive-funcall (funobj stack-location eip-location) "Is stack-frame in a primitive-function? If so, return the primitive-function's code-vector." + (declare (ignore eip-location)) (let ((return-address (memref stack-location 0 0 :unsigned-byte32)) (code-vector (funobj-code-vector funobj))) (multiple-value-bind (return-location return-delta) @@ -219,9 +233,9 @@ (:signed32 ;; We must read the unsigned-byte32 that starts at ip (let ((x (logior (aref code-vector (- ip 1)) - (* (aref code-vector (+ 0 ip)) #x100) - (* (aref code-vector (+ 1 ip)) #x10000) - (* (aref code-vector (+ 2 ip)) #x1000000)))) + (* (aref code-vector (+ 0 ip)) #x100) + (* (aref code-vector (+ 1 ip)) #x10000) + (* (aref code-vector (+ 2 ip)) #x1000000)))) (if (not (logbitp 7 (aref code-vector (+ ip 2)))) x (break "Negative 32-bit offset.")))) @@ -232,7 +246,10 @@ return-delta -3 -8))))) (primitive-function (%word-offset (%run-time-context-ref offset) -2))) - (check-type primitive-function code-vector) - (if (not (location-in-object-p primitive-function eip-location)) + (if (not (typep primitive-function 'code-vector)) nil primitive-function)))))))))) +;;; (check-type primitive-function code-vector) +;;; (if (not (location-in-object-p primitive-function eip-location)) +;;; nil +;;; primitive-function))))))))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp
by Frode Vatvedt Fjeld 20 Jul '04

20 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1565 Modified Files: scavenge.lisp Log Message: Map-stack-words inspects funobjs on the stack in order to determine the type of stack-frame etc. But the funobj might have migrated, which is why we must apply the mapping function to funobjs before we look at them. Date: Tue Jul 20 06:13:41 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.22 movitz/losp/muerte/scavenge.lisp:1.23 --- movitz/losp/muerte/scavenge.lisp:1.22 Tue Jul 20 05:37:04 2004 +++ movitz/losp/muerte/scavenge.lisp Tue Jul 20 06:13:41 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.22 2004/07/20 12:37:04 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.23 2004/07/20 13:13:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -142,11 +142,7 @@ (loop for nether-frame = start-stack-frame then frame and frame = (stack-frame-uplink start-stack-frame) then (stack-frame-uplink frame) while (plusp frame) - do (let ((funobj (stack-frame-funobj frame t))) - #+ignore - (format t "~&fill ~S frame for ~S" - (aref (%run-time-context-slot 'nursery-space) 0) - funobj) + do (let ((funobj (funcall function (stack-frame-funobj frame t) nil))) (typecase funobj (function (assert (= 0 (funobj-frame-num-unboxed funobj))) @@ -162,7 +158,7 @@ ;; 2. Pop to interrupted frame (setf nether-frame frame frame (stack-frame-uplink frame)) - (let ((interrupted-funobj (stack-frame-funobj frame)) + (let ((interrupted-funobj (funcall function (stack-frame-funobj frame t) nil)) (interrupted-esp (+ interrupt-frame 6))) (assert (typep interrupted-funobj 'function) () "Interrupted frame was not a normal function: ~S"

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp
by Frode Vatvedt Fjeld 20 Jul '04

20 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25514 Modified Files: primitive-functions.lisp Log Message: Made primitive-function ensure-heap-cons-variable no longer preserve EDX, because it's very difficult to preserve EDX while also observing the GC invariant that a primitive-function cannot call another primitive-function. Date: Tue Jul 20 06:00:00 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.31 movitz/losp/muerte/primitive-functions.lisp:1.32 --- movitz/losp/muerte/primitive-functions.lisp:1.31 Tue Jul 20 01:54:38 2004 +++ movitz/losp/muerte/primitive-functions.lisp Tue Jul 20 06:00:00 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.31 2004/07/20 08:54:38 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.32 2004/07/20 13:00:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -571,7 +571,7 @@ (:ret))) (define-primitive-function ensure-heap-cons-variable () - "Call with lended variable (a cons) in EAX. Preserves EDX." + "Call with lended variable (a cons) in EAX." (with-inline-assembly (:returns :multiple-values) ;; Be defensive: Check that EAX is LISTP. (:leal (:eax -1) :ecx) @@ -582,12 +582,10 @@ (:cmpl :esp :eax) ; is cons below stack-frame? (:jl 'return-ok) ;; must migrate cell onto heap - (:pushl :edx) (:movl (:eax 3) :ebx) ; cdr (:movl (:eax -1) :eax) ; car - (:locally (:call (:edi (:edi-offset fast-cons)))) - (:popl :edx) - return-ok + (:locally (:jmp (:edi (:edi-offset fast-cons)))) + return-ok (:ret))) (define-primitive-function box-u32-ecx () @@ -614,7 +612,7 @@ (define-primitive-function unbox-u32 () - "Load (ldb (byte 32 0) EAX) into ECX." + "Load (ldb (byte 32 0) EAX) into ECX. Preserve EAX and EBX." (macrolet ((do-it () `(with-inline-assembly (:returns :multiple-values)

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by Frode Vatvedt Fjeld 20 Jul '04

20 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv25072 Modified Files: compiler.lisp Log Message: Made primitive-function ensure-heap-cons-variable no longer preserve EDX, because it's very difficult to preserve EDX while also observing the GC invariant that a primitive-function cannot call another primitive-function. Date: Tue Jul 20 05:59:53 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.79 movitz/compiler.lisp:1.80 --- movitz/compiler.lisp:1.79 Tue Jul 20 04:39:21 2004 +++ movitz/compiler.lisp Tue Jul 20 05:59:53 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.79 2004/07/20 11:39:21 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.80 2004/07/20 12:59:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3489,7 +3489,9 @@ (append (make-load-lexical lended-binding :eax funobj t frame-map) (unless (or (typep lended-binding 'borrowed-binding) (getf (binding-lended-p lended-binding) :dynamic-extent-p)) - (append `((:globally (:call (:edi (:edi-offset ensure-heap-cons-variable))))) + (append `((:pushl :edx) + (:globally (:call (:edi (:edi-offset ensure-heap-cons-variable)))) + (:popl :edx)) (make-store-lexical lended-binding :eax t frame-map))) `((:movl :eax (,funobj-register

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp
by Frode Vatvedt Fjeld 20 Jul '04

20 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11201 Modified Files: functions.lisp Log Message: Minor edit Date: Tue Jul 20 05:58:35 2004 Author: ffjeld Index: movitz/losp/muerte/functions.lisp diff -u movitz/losp/muerte/functions.lisp:1.16 movitz/losp/muerte/functions.lisp:1.17 --- movitz/losp/muerte/functions.lisp:1.16 Thu Jul 15 14:06:59 2004 +++ movitz/losp/muerte/functions.lisp Tue Jul 20 05:58:34 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.16 2004/07/15 21:06:59 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.17 2004/07/20 12:58:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -395,7 +395,7 @@ (defun copy-funobj (old-funobj &optional (name (funobj-name old-funobj))) (let* ((num-constants (funobj-num-constants old-funobj)) - (funobj (malloc-pointer-words (+ #.(cl:truncate (bt:sizeof 'movitz:movitz-funobj) 4) + (funobj (malloc-pointer-words (+ #.(movitz::movitz-type-word-size 'movitz-funobj) num-constants)))) (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:type) 0 :unsigned-byte16) (memref old-funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:type) 0 :unsigned-byte16))

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp
by Frode Vatvedt Fjeld 20 Jul '04

20 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv13248 Modified Files: debugger.lisp Log Message: fixnum-word is deprecated. Date: Tue Jul 20 05:40:48 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.16 movitz/losp/x86-pc/debugger.lisp:1.17 --- movitz/losp/x86-pc/debugger.lisp:1.16 Wed Jul 14 17:28:30 2004 +++ movitz/losp/x86-pc/debugger.lisp Tue Jul 20 05:40:48 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.16 2004/07/15 00:28:30 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.17 2004/07/20 12:40:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -533,7 +533,3 @@ (t (format t "~&?: ~Z" funobj)))))) (values)) -(defun fixnum-word (fixnum) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) fixnum) - (:shrl #.movitz::+movitz-fixnum-shift+ :eax)))

1 0

[movitz-cvs] CVS update: movitz/special-operators.lisp
by Frode Vatvedt Fjeld 20 Jul '04

20 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv2886 Modified Files: special-operators.lisp Log Message: Improved compiler-macro-call so that it works on setf operators. Date: Tue Jul 20 05:40:07 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.30 movitz/special-operators.lisp:1.31 --- movitz/special-operators.lisp:1.30 Sat Jul 17 05:17:35 2004 +++ movitz/special-operators.lisp Tue Jul 20 05:40:07 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.30 2004/07/17 12:17:35 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.31 2004/07/20 12:40:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1057,11 +1057,14 @@ (define-special-operator muerte::compiler-macro-call (&all all &form form &env env) (destructuring-bind (operator &rest arguments) (cdr form) - (assert (movitz-compiler-macro-function operator env) () - "There is no compiler-macro ~S." operator) - (compiler-call #'compile-compiler-macro-form - :forward all - :form (cons operator arguments)))) + (let ((name (if (not (setf-name operator)) + operator + (movitz-env-setf-operator-name (setf-name operator))))) + (assert (movitz-compiler-macro-function name env) () + "There is no compiler-macro ~S." name) + (compiler-call #'compile-compiler-macro-form + :forward all + :form (cons name arguments))))) (define-special-operator muerte::do-result-mode-case (&all all &result-mode result-mode &form form) (loop for (cases . then-forms) in (cddr form)

1 0

[movitz-cvs] CVS update: movitz/packages.lisp
by Frode Vatvedt Fjeld 20 Jul '04

20 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24421 Modified Files: packages.lisp Log Message: More symbols. Date: Tue Jul 20 05:39:16 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.33 movitz/packages.lisp:1.34 --- movitz/packages.lisp:1.33 Thu Jul 15 14:06:24 2004 +++ movitz/packages.lisp Tue Jul 20 05:39:16 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.33 2004/07/15 21:06:24 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.34 2004/07/20 12:39:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1243,7 +1243,9 @@ runtime-context-slot movitz-accessor halt-cpu - fixnum-word + #:%object-lispval + #:%lispval-object + #:objects-equalp word-nibble &edx

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp
by Frode Vatvedt Fjeld 20 Jul '04

20 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16368 Modified Files: arrays.lisp Log Message: Minor edits. Date: Tue Jul 20 05:38:59 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.36 movitz/losp/muerte/arrays.lisp:1.37 --- movitz/losp/muerte/arrays.lisp:1.36 Thu Jul 15 14:06:42 2004 +++ movitz/losp/muerte/arrays.lisp Tue Jul 20 05:38:59 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.36 2004/07/15 21:06:42 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.37 2004/07/20 12:38:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -490,14 +490,17 @@ `(memref ,vector 2 ,index :unsigned-byte32)) (defun u32ref%unsafe (vector index) - (u32ref%unsafe vector index)) + (compiler-macro-call u32ref%unsafe vector index)) (define-compiler-macro (setf u32ref%unsafe) (value vector index) - `(setf (memref ,vector 2 ,index :unsigned-byte32) ,value)) + (let ((var (gensym "setf-u32ref-value-"))) + ;; Use var so as to avoid re-boxing of the u32 value. + `(let ((,var ,value)) + (setf (memref ,vector 2 ,index :unsigned-byte32) ,var) + ,var))) (defun (setf u32ref%unsafe) (value vector index) - (setf (u32ref%unsafe vector index) value) - value) + (compiler-macro-call (setf u32ref%unsafe) value vector index)) ;;; fast vector access

1 0