movitz-cvs September 2004

movitz-cvs@common-lisp.net

1 participants
91 discussions

[movitz-cvs] CVS update: movitz/assembly-syntax.lisp
by Frode Vatvedt Fjeld 06 Sep '04

06 Sep '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv31132 Modified Files: assembly-syntax.lisp Log Message: Slightly cleaned up assembly-macroexpand, and added a work-around for an apparent bug in CMUCL's loop. Date: Mon Sep 6 12:07:03 2004 Author: ffjeld Index: movitz/assembly-syntax.lisp diff -u movitz/assembly-syntax.lisp:1.3 movitz/assembly-syntax.lisp:1.4 --- movitz/assembly-syntax.lisp:1.3 Wed Apr 21 17:05:39 2004 +++ movitz/assembly-syntax.lisp Mon Sep 6 12:07:03 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 9 17:34:37 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: assembly-syntax.lisp,v 1.3 2004/04/21 15:05:39 ffjeld Exp $ +;;;; $Id: assembly-syntax.lisp,v 1.4 2004/09/06 10:07:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -26,20 +26,18 @@ expander)) (defun assembly-macroexpand (prg amenv) - (let* ((fix-tail nil) - (new-prg - (loop for (p . tail) on prg - as expander = (and (consp p) - (symbolp (car p)) - (assembly-macro-expander (car p) amenv)) - if expander - append (funcall expander p) - else if (consp p) - append (list (assembly-macroexpand p amenv)) - else append (list p) - unless (listp tail) - do (setf fix-tail tail)))) - (when fix-tail - (setf (cdr (last new-prg)) fix-tail)) - new-prg)) + #+cmu (declare (optimize (safety 0))) ; Circumvent CMUCL bug in loop for-as-on-list. + (loop for (p . tail) on prg + as expander = (and (consp p) + (symbolp (car p)) + (assembly-macro-expander (car p) amenv)) + if expander + append (funcall expander p) into result + else if (consp p) + append (list (assembly-macroexpand p amenv)) into result + else append (list p) into result + when (not (listp tail)) + do (setf (cdr (last result)) tail) + (return result) + finally (return result)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/variables.lisp
by Frode Vatvedt Fjeld 02 Sep '04

02 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24685 Modified Files: variables.lisp Log Message: Add variable *multiboot-data*. Date: Thu Sep 2 11:46:14 2004 Author: ffjeld Index: movitz/losp/muerte/variables.lisp diff -u movitz/losp/muerte/variables.lisp:1.6 movitz/losp/muerte/variables.lisp:1.7 --- movitz/losp/muerte/variables.lisp:1.6 Thu Jul 8 20:54:05 2004 +++ movitz/losp/muerte/variables.lisp Thu Sep 2 11:46:14 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 5 21:53:34 2003 ;;;; -;;;; $Id: variables.lisp,v 1.6 2004/07/08 18:54:05 ffjeld Exp $ +;;;; $Id: variables.lisp,v 1.7 2004/09/02 09:46:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -39,7 +39,8 @@ (defparameter *debugger-hook* nil) (defvar *active-condition-handlers* nil) +(defvar *multiboot-data* nil) (defvar internal-time-units-per-second) -(declaim (special *build-number*)) \ No newline at end of file +(declaim (special *build-number*))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp
by Frode Vatvedt Fjeld 02 Sep '04

02 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24399 Modified Files: interrupt.lisp Log Message: Various tweaks. Removed the stack-top and stack-bottom operators; use the %run-time-context-slot accessor instead. Date: Thu Sep 2 11:45:27 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.21 movitz/losp/muerte/interrupt.lisp:1.22 --- movitz/losp/muerte/interrupt.lisp:1.21 Thu Aug 19 00:37:56 2004 +++ movitz/losp/muerte/interrupt.lisp Thu Sep 2 11:45:26 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.21 2004/08/18 22:37:56 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.22 2004/09/02 09:45:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -118,8 +118,8 @@ (:call (:pc+ 0)) ; push EIP. ;; Now add a few bytes to the on-stack EIP so the iret goes to ;; *DEST* below. - ((4) :addl 5 (:esp)) ; 4 bytes - ((1) :iretd) ; 1 byte + (((:size 4)) :addl 5 (:esp)) ; 4 bytes + (((:size 1)) :iretd) ; 1 byte ;; *DEST* iret branches to here. ;; we're now in the context of the interruptee. @@ -321,11 +321,12 @@ (with-inline-assembly (:returns :nothing) (:nop)))) (70 (error "Unaligned memref access.")) ((5 55) - (let* ((old-bottom (prog1 (stack-bottom) - (setf (stack-bottom) 0))) + (let* ((old-bottom (prog1 (%run-time-context-slot 'stack-bottom) + (setf (%run-time-context-slot 'stack-bottom) 0))) (stack (%run-time-context-slot 'movitz::stack-vector)) (real-bottom (- (object-location stack) 2)) (stack-left (- old-bottom real-bottom)) + (old-dynamic-env (%run-time-context-slot 'dynamic-env)) (new-bottom (cond ((< stack-left 10) (princ "Halting CPU due to stack exhaustion.") @@ -334,20 +335,23 @@ (format *debug-io* "~&This is your LAST chance to pop off stack.~%") real-bottom) - (t (+ real-bottom (truncate stack-left 2)))))) ; Cushion the fall.. + (t (+ real-bottom (truncate stack-left 4)))))) ; Cushion the fall.. (unwind-protect (progn - (setf (stack-bottom) new-bottom) - (format *debug-io* "~&Stack-warning: Bumped stack-bottom by ~D to #x~X.~%" + (setf (%run-time-context-slot 'stack-bottom) new-bottom + (%run-time-context-slot 'dynamic-env) 0) + (format *debug-io* "~&Stack-warning: Bumped stack-bottom by ~D to #x~X. Reset ENV.~%" (- old-bottom new-bottom) new-bottom) - (break "Stack overload exception ~D at EIP=~@Z, ESI=~@Z, ESP=~@Z, bottom=#x~X." - vector $eip $esi - (+ dit-frame (dit-frame-index :ebp)) - old-bottom)) + (break "Stack overload exception ~D at EIP=~@Z, ESP=~@Z, bottom=#x~X, ENV=#x~X." + vector $eip + (dit-frame-esp dit-frame) + old-bottom + old-dynamic-env)) (format *debug-io* "~&Stack-warning: Resetting stack-bottom to #x~X.~%" old-bottom) - (setf (stack-bottom) old-bottom)))) + (setf (%run-time-context-slot 'stack-bottom) old-bottom + (%run-time-context-slot 'dynamic-env) old-dynamic-env)))) (69 (error "Not a function: ~S" (dereference $edx))) (70

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp
by Frode Vatvedt Fjeld 02 Sep '04

02 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24026 Modified Files: sequences.lisp Log Message: Don't use the dubious memcopy operator. Date: Thu Sep 2 11:44:15 2004 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.17 movitz/losp/muerte/sequences.lisp:1.18 --- movitz/losp/muerte/sequences.lisp:1.17 Mon Aug 16 10:26:40 2004 +++ movitz/losp/muerte/sequences.lisp Thu Sep 2 11:44:15 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.17 2004/08/16 08:26:40 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.18 2004/09/02 09:44:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -736,23 +736,18 @@ (sequence-dispatch sequence-2 (vector (setf end2 (or end2 (length sequence-2))) - (vector-double-dispatch (sequence-1 sequence-2) - ((:u8 :u8) - (memcopy sequence-1 sequence-2 2 start1 start2 - (min (- end1 start1) (- end2 start2)) - :unsigned-byte8)) - (t (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1) - (with-subvector-accessor (sequence-2-ref sequence-2 start2 end2) - (cond - ((< (- end1 start1) (- end2 start2)) - (do ((i start1 (1+ i)) - (j start2 (1+ j))) - ((>= i end1) sequence-1) - (setf (sequence-1-ref i) (sequence-2-ref j)))) - (t (do ((i start1 (1+ i)) - (j start2 (1+ j))) - ((>= j end2) sequence-1) - (setf (sequence-1-ref i) (sequence-2-ref j)))))))))) + (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1) + (with-subvector-accessor (sequence-2-ref sequence-2 start2 end2) + (cond + ((< (- end1 start1) (- end2 start2)) + (do ((i start1 (1+ i)) + (j start2 (1+ j))) + ((>= i end1) sequence-1) + (setf (sequence-1-ref i) (sequence-2-ref j)))) + (t (do ((i start1 (1+ i)) + (j start2 (1+ j))) + ((>= j end2) sequence-1) + (setf (sequence-1-ref i) (sequence-2-ref j)))))))) (list (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1) (if (not end2)

1 0

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

02 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv22179 Modified Files: debugger.lisp Log Message: Refer to stack-slots with two values: a stack and an frame. If stack is NIL, frame is the location (in the current stack) of the stack-slot. If stack is a vector, frame is an index into this vector. Date: Thu Sep 2 11:41:19 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.22 movitz/losp/x86-pc/debugger.lisp:1.23 --- movitz/losp/x86-pc/debugger.lisp:1.22 Mon Aug 23 15:58:41 2004 +++ movitz/losp/x86-pc/debugger.lisp Thu Sep 2 11:41:18 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.22 2004/08/23 13:58:41 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.23 2004/09/02 09:41:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -499,7 +499,7 @@ (function (let ((delta (code-vector-offset (funobj-code-vector funobj) eip))) (if delta - (format t "{Exception ~D in ~W at PC offset ~D." + (format t "{Exception ~D in ~W at PC offset ~D.}" exception (funobj-name funobj) delta) (format t "{Exception ~D in ~W at EIP=#x~X.}" exception (funobj-name funobj) eip))))

1 0

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

02 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22121 Modified Files: scavenge.lisp Log Message: Refer to stack-slots with two values: a stack and an frame. If stack is NIL, frame is the location (in the current stack) of the stack-slot. If stack is a vector, frame is an index into this vector. Date: Thu Sep 2 11:41:10 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.27 movitz/losp/muerte/scavenge.lisp:1.28 --- movitz/losp/muerte/scavenge.lisp:1.27 Mon Aug 23 15:58:34 2004 +++ movitz/losp/muerte/scavenge.lisp Thu Sep 2 11:41:09 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.27 2004/08/23 13:58:34 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.28 2004/09/02 09:41:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -111,7 +111,8 @@ (assert (evenp scan) () "Scanned ~Z at odd location #x~X." x scan) (let ((len (memref scan 0 1 :lisp))) - (check-type len positive-fixnum) + (assert (typep len 'positive-fixnum) () + "Scanned basic-vector at ~S with illegal length ~S." scan len) (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (incf scan (1+ (logand (1+ len) -2))))) ((and (scavenge-typep x :basic-vector) @@ -141,10 +142,18 @@ (loop for nether-frame = start-frame then frame and frame = (stack-frame-uplink stack start-frame) then (stack-frame-uplink stack frame) while (plusp frame) - do (let ((funobj (funcall function (stack-frame-funobj stack frame) nil))) + do (let ((funobj (funcall function (stack-frame-funobj stack frame) frame))) (typecase funobj - (function + ((or function null) (assert (= 0 (funobj-frame-num-unboxed funobj))) + #+ignore + (assert (typep (stack-frame-ref stack frame 1 :lisp) '(or (eql 0) + (not (or fixnum character)))) + () "Malaligned CALL in function ~S at #x~X, frame ~S." + (and (plusp (stack-frame-uplink stack frame)) + (stack-frame-funobj stack (stack-frame-uplink stack frame))) + (stack-frame-ref stack frame 1 :unsigned-byte32) + frame) (map-heap-words function (+ nether-frame 2) frame)) ((eql 0) ; An dit interrupt-frame? (let* ((dit-frame frame) @@ -167,95 +176,59 @@ ;; 2. Pop to (dit-)frame's CASF (setf nether-frame frame frame (dit-frame-casf frame)) - (let ((casf-funobj (funcall function (stack-frame-funobj stack frame) nil)) + (let ((casf-funobj (funcall function (stack-frame-funobj stack frame) frame)) (interrupted-esp (dit-frame-esp dit-frame))) (cond + ((eq nil casf-funobj) + (warn "Scanning interrupt in PF: ~S" + (dit-frame-ref :eip :unsigned-byte32 0 dit-frame))) ((eq 0 casf-funobj) - (warn "Interrupt (presumably) in interrupt trampoline.")) - (t (assert (typep casf-funobj 'function) () - "Interrupted CASF frame was not a normal function: ~S" - casf-funobj) - (let ((casf-code-vector (funobj-code-vector casf-funobj))) - ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii. + (warn "Interrupt (presumably) in interrupt trampoline.")) + ((typep casf-funobj 'function) + (let ((casf-code-vector (funobj-code-vector casf-funobj))) + ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii. + (cond + ((location-in-object-p casf-code-vector + (dit-frame-ref :eip :location 0 dit-frame)) (cond - ((location-in-object-p casf-code-vector - (dit-frame-ref :eip :location 0 dit-frame)) - ;; Situation i. Nothing special on stack, scavenge frame normally. - (map-heap-words function interrupted-esp frame)) - ((eq casf-frame (memref interrupted-esp 0 0 :location)) - ;; Situation ii. esp(0)=CASF, esp(1)=code-vector - (assert (location-in-object-p casf-code-vector - (memref interrupted-esp 0 1 :location)) - () "Stack discipline situation ii. invariant broken. CASF=#x~X" - casf-frame) + ((let ((x0-tag (ldb (byte 3 0) + (memref interrupted-esp 0 0 :unsigned-byte8)))) + (and (member x0-tag '(1 5 6 7)) + (location-in-object-p casf-code-vector + (memref interrupted-esp 0 0 :location)))) + ;; When code-vector migration is implemented... + (warn "Scanning at ~S X0 call ~S in ~S." + (dit-frame-ref :eip :unsigned-byte32 0 dit-frame) + (memref interrupted-esp 0 0 :unsigned-byte32) + (funobj-name casf-funobj)) + (map-heap-words function (+ interrupted-esp 1) frame)) + ((let ((x1-tag (ldb (byte 3 0) + (memref interrupted-esp 4 0 :unsigned-byte8)))) + (and (member x1-tag '(1 5 6 7)) + (location-in-object-p casf-code-vector + (memref interrupted-esp 0 1 :location)))) + ;; When code-vector migration is implemented... + (warn "Scanning at ~S X1 call ~S in ~S." + (dit-frame-ref :eip :unsigned-byte32 0 dit-frame) + (memref interrupted-esp 0 1 :unsigned-byte32) + (funobj-name casf-funobj)) (map-heap-words function (+ interrupted-esp 2) frame)) - (t ;; Situation iii. esp(0)=code-vector. - (assert (location-in-object-p casf-code-vector - (memref interrupted-esp 0 0 :location)) - () "Stack discipline situation iii. invariant broken. CASF=#x~X" - casf-frame) - (map-heap-words function (+ interrupted-esp 1) frame))))))))) + (t ;; Situation i. Nothing special on stack, scavenge frame normally. + (map-heap-words function interrupted-esp frame)))) + ((eq casf-frame (memref interrupted-esp 0 0 :location)) + ;; Situation ii. esp(0)=CASF, esp(1)=code-vector + (assert (location-in-object-p casf-code-vector + (memref interrupted-esp 0 1 :location)) + () "Stack discipline situation ii. invariant broken. CASF=#x~X" + casf-frame) + (map-heap-words function (+ interrupted-esp 2) frame)) + (t ;; Situation iii. esp(0)=code-vector. + (assert (location-in-object-p casf-code-vector + (memref interrupted-esp 0 0 :location)) + () "Stack discipline situation iii. invariant broken. CASF=#x~X" + casf-frame) + (map-heap-words function (+ interrupted-esp 1) frame))))) + (t (error "DIT-frame interrupted unknown CASF funobj: ~S" casf-funobj)))))) (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj))))) (values)) -;;;(defparameter *primitive-funcall-patterns* -;;; '((:or -;;; (#xff #x57 (:function-offset :signed8)) ; -;;; (#xff #x97 (:function-offset :signed32))))) ; -;;; -;;;(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)) -;;; ;; XXXX Really we should make comparisons against :call-local-pf -;;; ;; such that we find the active set of local-pf's from the stack-location! -;;; (let ((return-address (memref stack-location 0 0 :unsigned-byte32)) -;;; (code-vector (funobj-code-vector funobj))) -;;; (multiple-value-bind (return-location return-delta) -;;; (truncate return-address #.movitz:+movitz-fixnum-factor+) -;;; (if (not (location-in-object-p code-vector return-location)) -;;; nil ; A PF must have return-address on top of stack. -;;; (dotimes (offset 5 (warn "mismatch in ~S at ~D from #x~X in ~Z." -;;; funobj -;;; (+ (* (- return-location -;;; (object-location code-vector)) -;;; #.movitz:+movitz-fixnum-factor+) -;;; return-delta -;;; -3 -8) -;;; return-address code-vector)) -;;; (multiple-value-bind (success-p type code ip) -;;; (match-code-pattern *primitive-funcall-patterns* -;;; code-vector (+ (* (- return-location -;;; (object-location code-vector)) -;;; #.movitz:+movitz-fixnum-factor+) -;;; return-delta -;;; -3 -8 (- offset)) -;;; :function-offset) -;;; (when success-p -;;; (return -;;; (let* ((offset (case type -;;; (:signed8 -;;; (if (not (logbitp 7 code)) code (- code 256))) -;;; (: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)))) -;;; (if (not (logbitp 7 (aref code-vector (+ ip 2)))) -;;; x -;;; (break "Negative 32-bit offset.")))) -;;; (t (break "Match fail: vec: ~Z, ip: ~D" -;;; code-vector (+ (* (- return-location -;;; (object-location code-vector)) -;;; #.movitz:+movitz-fixnum-factor+) -;;; return-delta -;;; -3 -8))))) -;;; (primitive-function (%word-offset (%run-time-context-ref offset) -2))) -;;; (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/restarts.lisp
by Frode Vatvedt Fjeld 02 Sep '04

02 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22101/losp/muerte Modified Files: restarts.lisp Log Message: Refer to stack-slots with two values: a stack and an frame. If stack is NIL, frame is the location (in the current stack) of the stack-slot. If stack is a vector, frame is an index into this vector. Date: Thu Sep 2 11:41:04 2004 Author: ffjeld Index: movitz/losp/muerte/restarts.lisp diff -u movitz/losp/muerte/restarts.lisp:1.3 movitz/losp/muerte/restarts.lisp:1.4 --- movitz/losp/muerte/restarts.lisp:1.3 Wed Jul 14 00:44:10 2004 +++ movitz/losp/muerte/restarts.lisp Thu Sep 2 11:41:04 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 28 09:27:13 2003 ;;;; -;;;; $Id: restarts.lisp,v 1.3 2004/07/13 22:44:10 ffjeld Exp $ +;;;; $Id: restarts.lisp,v 1.4 2004/09/02 09:41:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -33,10 +33,12 @@ (restart-bind ,rest-specs ,@body)))))) (defun dynamic-context->basic-restart (context) - (assert (< (stack-bottom) (truncate context 4) (stack-top))) + (assert (< (%run-time-context-slot 'stack-bottom) + context + (%run-time-context-slot 'stack-top))) (assert (eq (load-global-constant restart-tag) - (stack-ref context 0 1 :lisp))) - (let ((x (- (* 4 (stack-top)) context))) + (stack-frame-ref nil context 1 :lisp))) + (let ((x (- (%run-time-context-slot 'stack-top) context))) (assert (below x #x1000000)) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) x) @@ -51,17 +53,17 @@ (:locally (:movl (:edi (:edi-offset stack-top)) :ecx)) (:shrl 6 :eax) (:negl :eax) - (:leal (:eax (:ecx #.movitz::+movitz-fixnum-factor+)) :eax))) + (:leal (:eax :ecx) :eax))) (define-simple-typep (basic-restart basic-restart-p) (x) (with-inline-assembly (:returns :boolean-zf=1) (:compile-form (:result-mode :eax) x) (:cmpb #.(movitz::tag :basic-restart) :al) (:jne 'fail) - (:shrl 8 :eax) + (:shrl 6 :eax) (:locally (:movl (:edi (:edi-offset stack-top)) :ecx)) (:locally (:movl (:edi (:edi-offset dynamic-env)) :ebx)) - (:shll 2 :ebx) +;; (:shll 2 :ebx) (:subl :ebx :ecx) (:cmpl :eax :ecx) (:jna 'fail) @@ -74,38 +76,38 @@ (defun restart-name (restart) (etypecase restart (basic-restart - (stack-ref (basic-restart->dynamic-context restart) - 0 -1 :lisp)))) + (stack-frame-ref nil (basic-restart->dynamic-context restart) + -1 :lisp)))) (defun restart-function (restart) (etypecase restart (basic-restart - (stack-ref (basic-restart->dynamic-context restart) - 0 -2 :lisp)))) + (stack-frame-ref nil (basic-restart->dynamic-context restart) + -2 :lisp)))) (defun restart-interactive-function (restart) (etypecase restart (basic-restart - (stack-ref (basic-restart->dynamic-context restart) - 0 -3 :lisp)))) + (stack-frame-ref nil (basic-restart->dynamic-context restart) + -3 :lisp)))) (defun restart-test (restart) (etypecase restart (basic-restart - (stack-ref (basic-restart->dynamic-context restart) - 0 -4 :lisp)))) + (stack-frame-ref nil (basic-restart->dynamic-context restart) + -4 :lisp)))) (defun restart-format-control (restart) (etypecase restart (basic-restart - (stack-ref (basic-restart->dynamic-context restart) - 0 -5 :lisp)))) + (stack-frame-ref nil (basic-restart->dynamic-context restart) + -5 :lisp)))) (defun restart-args (restart) (etypecase restart (basic-restart - (stack-ref (basic-restart->dynamic-context restart) - 0 -6 :lisp)))) + (stack-frame-ref nil (basic-restart->dynamic-context restart) + -6 :lisp)))) (defun invoke-restart (restart-designator &rest arguments) (declare (dynamic-extent arguments)) @@ -118,7 +120,7 @@ (apply function arguments)) (symbol (exact-throw (load-global-constant restart-tag) - (truncate (basic-restart->dynamic-context restart) 4) + (basic-restart->dynamic-context restart) (ecase function ((with-simple-restart) (values nil t))))))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp
by Frode Vatvedt Fjeld 02 Sep '04

02 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22035 Modified Files: memref.lisp Log Message: Fix the (setf memref-int) compiler-macro to observe register discipline. Date: Thu Sep 2 11:38:46 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.27 movitz/losp/muerte/memref.lisp:1.28 --- movitz/losp/muerte/memref.lisp:1.27 Tue Aug 17 01:15:12 2004 +++ movitz/losp/muerte/memref.lisp Thu Sep 2 11:38:46 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.27 2004/08/16 23:15:12 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.28 2004/09/02 09:38:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -72,16 +72,16 @@ (:unsigned-byte8 (cond ((and (eq 0 offset) (eq 0 index)) - `(with-inline-assembly (:returns :untagged-fixnum-ecx) + `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8)) (:compile-form (:result-mode :eax) ,object) (:movzxb (:eax ,(offset-by 1)) :ecx))) ((eq 0 offset) - `(with-inline-assembly (:returns :untagged-fixnum-ecx) + `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8)) (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object ,index) (:movzxb (:eax :ecx ,(offset-by 1)) :ecx))) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) - (with-inline-assembly (:returns :untagged-fixnum-ecx) + (with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8)) (:compile-two-forms (:ecx :ebx) ,offset ,index) (:load-lexical (:lexical-binding ,object-var) :eax) (:addl :ebx :ecx) ; index += offset @@ -749,7 +749,7 @@ (memref-int address offset index :unsigned-byte32 t)))))) (define-compiler-macro (setf memref-int) (&whole form &environment env value address offset index type - &optional physicalp) + &optional physicalp) (if (or (not (movitz:movitz-constantp type env)) (not (movitz:movitz-constantp physicalp env))) (progn @@ -810,30 +810,45 @@ (:unsigned-byte16 (cond ((eq 0 offset) - `(with-inline-assembly (:returns :untagged-fixnum-eax) - (:compile-form (:result-mode :push) ,address) - (:compile-form (:result-mode :push) ,index) - (:compile-form (:result-mode :eax) ,value) - (:popl :ebx) ; index - (:shrl ,movitz::+movitz-fixnum-shift+ :eax) ; scale value - (:popl :ecx) ; address - (:shll 1 :ebx) ; scale index - (:addl :ebx :ecx) - (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale address - (,prefixes :movw :ax (:ecx)))) - (t `(with-inline-assembly (:returns :untagged-fixnum-eax) - (:compile-form (:result-mode :push) ,address) - (:compile-form (:result-mode :push) ,index) - (:compile-form (:result-mode :push) ,offset) - (:compile-form (:result-mode :eax) ,value) - (:popl :edx) ; offset - (:popl :ebx) ; index - (:popl :ecx) ; address - (:shrl ,movitz::+movitz-fixnum-shift+ :eax) ; scale value - (:leal (:ecx (:ebx 2)) :ecx) - (:addl :edx :ecx) ; - (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale offset+address - (,prefixes :movw :ax (:ecx)))))))))) + (let ((address-var (gensym "memref-int-address-")) + (index-var (gensym "memref-index-var-")) + (value-var (gensym "memref-value-var-"))) + `(let ((,value-var ,value) + (,address-var ,address) + (,index-var ,index)) + (with-inline-assembly (:returns :untagged-fixnum-eax) + (:load-lexical (:lexical-binding ,value-var) :eax) ; value + (:load-lexical (:lexical-binding ,index-var) :ebx) ; index + (:load-lexical (:lexical-binding ,address-var) :ecx) ; address + (:shll 1 :ebx) ; scale index + (:addl :ebx :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) ; scale address + (:std) + (:shrl ,movitz:+movitz-fixnum-shift+ :eax) ; scale value + (,prefixes :movw :ax (:ecx)) + (:leal ((:eax ,movitz:+movitz-fixnum-factor+)) :eax) + (:cld))))) + (t (let ((address-var (gensym "memref-int-address-")) + (offset-var (gensym "memref-offset-var-")) + (index-var (gensym "memref-index-var-")) + (value-var (gensym "memref-value-var-"))) + `(let ((,value-var ,value) + (,address-var ,address) + (,offset-var ,offset) + (,index-var ,index)) + (with-inline-assembly (:returns :untagged-fixnum-eax) + (:load-lexical (:lexical-binding ,address-var) :ecx) + (:load-lexical (:lexical-binding ,index-var) :ebx) + (:load-lexical (:lexical-binding ,offset-var) :edx) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:leal (:ecx (:ebx 2)) :ecx) + (:addl :edx :ecx) ; + (:shrl ,movitz::+movitz-fixnum-shift+ :eax) ; scale value + (:std) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale offset+address + (,prefixes :movw :ax (:ecx)) + (:leal ((:eax ,movitz:+movitz-fixnum-factor+)) :eax) + (:cld))))))))))) (defun (setf memref-int) (value address offset index type &optional physicalp) (cond

1 0

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

02 Sep '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv20090 Modified Files: los0-gc.lisp Log Message: When seeing if an object is already forwared during scavenge, be more careful about loading in the potential forwarding pointer. If it's not an actual forwarding pointer, we're not really allowed to load it in as a lispval. Date: Thu Sep 2 11:33:06 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.34 movitz/losp/los0-gc.lisp:1.35 --- movitz/losp/los0-gc.lisp:1.34 Mon Aug 23 15:58:07 2004 +++ movitz/losp/los0-gc.lisp Thu Sep 2 11:33:06 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.34 2004/08/23 13:58:07 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.35 2004/09/02 09:33:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -288,7 +288,7 @@ (let ((*standard-output* *terminal-io*)) (when *gc-running* (let ((muerte::*error-no-condition-for-debugger* t)) - (error "Recursive GC triggered."))) + (warn "Recursive GC triggered."))) (let ((*gc-running* t)) (unless *gc-quiet* (format t "~&;; GC.. ")) @@ -399,23 +399,26 @@ "If x is in oldspace, migrate it to newspace." (declare (ignore location)) (cond + ((null x) + nil) ((not (object-in-space-p oldspace x)) x) - (t (let ((forwarded-x (memref (object-location x) 0 0 :lisp))) - (if (object-in-space-p newspace forwarded-x) - (progn - (assert (eq (object-tag forwarded-x) - (object-tag x))) - forwarded-x) - (let ((forward-x (shallow-copy x))) - (when (and (typep x 'muerte::pointer) - *gc-consitency-check*) - (let ((a *x*)) - (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))))))))) + (t + (or (and (eq (object-tag x) + (ldb (byte 3 0) + (memref (object-location x) 0 0 :unsigned-byte8))) + (let ((forwarded-x (memref (object-location x) 0 0 :lisp))) + (and (object-in-space-p newspace forwarded-x) + forwarded-x))) + (let ((forward-x (shallow-copy x))) + (when (and (typep x 'muerte::pointer) + *gc-consitency-check*) + (let ((a *x*)) + (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%)

1 0

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

02 Sep '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv19116 Modified Files: special-operators.lisp Log Message: Implement the new stack-discipline-obeyant push/pop-current-values scheme. Date: Thu Sep 2 11:27:39 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.36 movitz/special-operators.lisp:1.37 --- movitz/special-operators.lisp:1.36 Sat Aug 14 19:45:17 2004 +++ movitz/special-operators.lisp Thu Sep 2 11:27:38 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.36 2004/08/14 17:45:17 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.37 2004/09/02 09:27:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -849,7 +849,9 @@ :type nil :modifies modifies :returns :nothing))) - (t (let* ((cloaked-env (make-instance 'with-things-on-stack-env :uplink env :funobj funobj)) + (t (let* ((cloaked-env (make-instance 'with-things-on-stack-env + :uplink env + :funobj funobj)) (cloaked-code (loop for cloaked-form in cloaked-forms append (compiler-values-bind (&code code &modifies sub-modifies) (compiler-call #'compile-form-unprotected @@ -942,11 +944,12 @@ :modifies modifies :type cover-type :code (append cover-code - `((:globally (:call (:edi (:edi-offset push-current-values)))) - (:pushl :ecx)) + (make-compiled-push-current-values) + `((:pushl :ecx)) cloaked-code `((:popl :ecx) - (:globally (:call (:edi (:edi-offset pop-current-values)))))))) + (:globally (:call (:edi (:edi-offset pop-current-values)))) + (:leal (:esp (:ecx 4)) :esp))))) ((and (not (cdr cloaked-code)) (instruction-is (car cloaked-code) :incf-lexvar)) (destructuring-bind (binding delta &key protect-registers)

1 0

← Newer
1
2
3
4
5
6
7
8
9
10
Older →

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs September 2004