January 2005 - movitz-cvs@common-lisp.net

[movitz-cvs] CVS update: public_html/index.html
by ffjeld＠common-lisp.net 29 Jan '05

29 Jan '05

Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv16960 Modified Files: index.html Log Message: *** empty log message *** Date: Sat Jan 29 02:38:47 2005 Author: ffjeld Index: public_html/index.html diff -u public_html/index.html:1.22 public_html/index.html:1.23 --- public_html/index.html:1.22 Sat Jan 29 02:36:56 2005 +++ public_html/index.html Sat Jan 29 02:38:47 2005 @@ -20,6 +20,9 @@ should, even in the corner cases when two interrupts occur in rapid succession etc. + January 4, 2005 Fixed some support for stack-allocating + funobjs and cons-cells of dynamic extent. + December 12, 2004: Various bits and pieces have been cleaned up so that recent (2.33) CLisp can now compile Movitz kernels just fine (mostly to do with CLisp having CL symbols with e.g. CLOS

1 0

[movitz-cvs] CVS update: public_html/index.html
by ffjeld＠common-lisp.net 29 Jan '05

29 Jan '05

Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv16922 Modified Files: index.html Log Message: *** empty log message *** Date: Sat Jan 29 02:36:56 2005 Author: ffjeld Index: public_html/index.html diff -u public_html/index.html:1.21 public_html/index.html:1.22 --- public_html/index.html:1.21 Sun Dec 12 04:38:40 2004 +++ public_html/index.html Sat Jan 29 02:36:56 2005 @@ -15,6 +15,11 @@ <h3>Most recent news</h3> + January 29, 2005 The stack discipline and associated GC + scavenging routines have been cleaned up, now hopefully work as they + should, even in the corner cases when two interrupts occur in rapid + succession etc. + December 12, 2004: Various bits and pieces have been cleaned up so that recent (2.33) CLisp can now compile Movitz kernels just fine (mostly to do with CLisp having CL symbols with e.g. CLOS

1 0

[movitz-cvs] CVS update: movitz/doc/ChangeLog
by ffjeld＠common-lisp.net 29 Jan '05

29 Jan '05

Update of /project/movitz/cvsroot/movitz/doc In directory common-lisp.net:/tmp/cvs-serv16868 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Jan 29 02:32:57 2005 Author: ffjeld Index: movitz/doc/ChangeLog diff -u movitz/doc/ChangeLog:1.9 movitz/doc/ChangeLog:1.10 --- movitz/doc/ChangeLog:1.9 Tue Jan 4 12:33:17 2005 +++ movitz/doc/ChangeLog Sat Jan 29 02:32:57 2005 @@ -1,3 +1,12 @@ +2005-01-29 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> + + * There's been quite a bit of work on scavenge.lisp. The stack scavenging + has been re-designed completely, and should now not break as it + sometimes did before in certain interrupt + situations. Interestingly, the scavenging API essentially didn't + change at all. There are still some holes left empty when it comes + to migrating code-vectors, but this should be trivial to fix. + 2005-01-04 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> * Fixed some support for stack-allocating funobjs and cons-cells

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp
by ffjeld＠common-lisp.net 28 Jan '05

28 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv439 Modified Files: interrupt.lisp Log Message: Fixed dit-frame-casf according to the (newish) stack discipline. Date: Fri Jan 28 00:49:07 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.36 movitz/losp/muerte/interrupt.lisp:1.37 --- movitz/losp/muerte/interrupt.lisp:1.36 Tue Jan 25 05:50:16 2005 +++ movitz/losp/muerte/interrupt.lisp Fri Jan 28 00:49:07 2005 @@ -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.36 2005/01/25 13:50:16 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.37 2005/01/28 08:49:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -82,20 +82,17 @@ (let ((ebp (dit-frame-ref stack dit-frame :ebp)) (esp (dit-frame-esp stack dit-frame))) (cond - ((null ebp) ; special mode + ((null ebp) ; special dynamic control-transfer mode (stack-frame-ref stack (dit-frame-ref stack dit-frame :dynamic-env) 0)) ((< esp ebp) ebp) - ((> esp ebp) - ;; A throw situation + ((eq esp ebp) (let ((next-ebp (stack-frame-ref stack esp 0))) (check-type next-ebp fixnum) (assert (< esp next-ebp)) next-ebp)) - (t (let ((next-ebp (stack-frame-ref stack esp 0))) - (check-type next-ebp fixnum) - (assert (< esp next-ebp)) - next-ebp))))) + (t (error "Undefined CASF for dit-frame ~S with EBP #x~X and ESP #x~X." + dit-frame ebp esp))))) (define-primitive-function (default-interrupt-trampoline :symtab-property t) () "Default first-stage/trampoline interrupt handler. Assumes the IF flag in EFLAGS

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp
by ffjeld＠common-lisp.net 28 Jan '05

28 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv418 Modified Files: scavenge.lisp Log Message: Fixed a typo in match-funobj, and removed the old scavenge function that's now defunct. Date: Fri Jan 28 00:47:18 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.43 movitz/losp/muerte/scavenge.lisp:1.44 --- movitz/losp/muerte/scavenge.lisp:1.43 Thu Jan 27 01:01:27 2005 +++ movitz/losp/muerte/scavenge.lisp Fri Jan 28 00:47:18 2005 @@ -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.43 2005/01/27 09:01:27 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.44 2005/01/28 08:47:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -173,17 +173,17 @@ (cond ((not (typep funobj 'function)) nil) - ((let ((x (funobj-code-vector casf-funobj))) + ((let ((x (funobj-code-vector funobj))) (and (location-in-object-p x location) x))) - ((let ((x (funobj-code-vector%1op casf-funobj))) + ((let ((x (funobj-code-vector%1op funobj))) (and (typep x 'vector) (location-in-object-p x location) x))) - ((let ((x (funobj-code-vector%2op casf-funobj))) + ((let ((x (funobj-code-vector%2op funobj))) (and (typep x 'vector) (location-in-object-p x location) x))) - ((let ((x (funobj-code-vector%3op casf-funobj))) + ((let ((x (funobj-code-vector%3op funobj))) (and (typep x 'vector) (location-in-object-p x location) x)))))) @@ -340,145 +340,4 @@ old) (t (setf (stack-frame-ref nil index 0) nil))))) - -#+ignore -(defun old-map-stack-vector (function stack start-frame &optional (map-region #'map-header-vals)) - "Map function over the potential pointer words of a stack, starting -at the start-stack-frame location." - (with-funcallable (map-region) - (loop with next-frame with next-nether-frame - for nether-frame = start-frame then (or next-nether-frame frame) - and frame = (stack-frame-uplink stack start-frame) then (or next-frame - (stack-frame-uplink stack frame)) - while (plusp frame) - do (setf next-frame nil next-nether-frame nil) - do (flet ((scavenge-funobj-code-vector (funobj) - "Funobj 0 is assumed to be the DIT code-vector." - (if (eq 0 funobj) - (symbol-value 'default-interrupt-trampoline) - (funobj-code-vector funobj)))) - (let ((funobj (funcall function (stack-frame-funobj stack frame) frame))) - ;; If nether-frame is a DIT-frame, there are 4 more words to be skipped. - (when (eq 0 (stack-frame-ref stack nether-frame -1)) - (incf nether-frame 4)) - (typecase funobj - ((or function null) - (assert (= 0 (funobj-frame-raw-locals funobj))) - (map-region function (+ nether-frame 2) frame)) - ((eql 0) ; A dit interrupt-frame? - (let* ((dit-frame frame) - (casf-frame (dit-frame-casf stack dit-frame))) - ;; 1. Scavenge the dit-frame - (cond - ((let ((atomically (dit-frame-ref stack dit-frame :atomically-continuation - :unsigned-byte32))) - (and (not (= 0 atomically)) - (= 0 (ldb (byte 2 0) atomically)))) - ;; Interrupt occurred inside an (non-pf) atomically, so none of the - ;; registers are active. - (map-region function (+ nether-frame 2) - (+ dit-frame 1 (dit-frame-index :tail-marker)))) - ((logbitp 10 (dit-frame-ref stack dit-frame :eflags :unsigned-byte32)) - ;; DF flag was 1, so EAX and EDX are not GC roots. - #+ignore (warn "Interrupt in uncommon mode at ~S" - (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) - (map-region function ; Assume nothing in the dit-frame above the location .. - (+ nether-frame 2) ; ..of EDX holds pointers. - (+ dit-frame (dit-frame-index :edx)))) - (t #+ignore (warn "Interrupt in COMMON mode!") - (map-region function ; Assume nothing in the dit-frame above the location .. - (+ nether-frame 2) ; ..of ECX holds pointers. - (+ dit-frame (dit-frame-index :ecx))))) - ;; 2. Pop to (dit-)frame's CASF - (setf nether-frame dit-frame - frame casf-frame #+ignore (dit-frame-casf stack frame)) - (let ((eip-location (dit-frame-ref stack dit-frame :eip :location)) - (interrupted-esp (dit-frame-esp stack dit-frame)) - (interrupted-ebp (dit-frame-ref stack dit-frame :ebp)) - (casf-funobj (funcall function (stack-frame-funobj stack frame) frame))) - (cond - ((or (eq 0 casf-funobj) - (typep casf-funobj 'function)) - (let ((casf-code-vector (scavenge-funobj-code-vector casf-funobj))) - ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii. - (cond - ((eq nil interrupted-ebp) - (cond - ((location-in-object-p casf-code-vector eip-location) - (warn "DIT at throw situation, in target ~S at ~S" - casf-funobj - (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) - (map-region function interrupted-esp frame)) - ((location-in-object-p (%run-time-context-slot 'dynamic-jump-next) - eip-location) - (warn "DIT at throw situation, in dynamic-jump-next.") - (let ((dynamic-env (dit-frame-ref stack dit-frame :dynamic-env))) - (assert (< dynamic-env frame)) - (map-region function dynamic-env frame))) - (t (error "Unknown throw situation with EBP=~S, ESP=~S" - interrupted-ebp interrupted-esp)))) - ((location-in-object-p casf-code-vector - (dit-frame-ref stack dit-frame :eip :location)) - (cond - ((let ((x0-tag (ldb (byte 3 0) - (memref interrupted-esp 0 :type :unsigned-byte8)))) - (and (member x0-tag '(1 5 6 7)) - (location-in-object-p casf-code-vector - (memref interrupted-esp 0 :type :location)))) - ;; When code-vector migration is implemented... - (warn "Scanning at ~S X0 call ~S in ~S." - (dit-frame-ref stack dit-frame :eip :unsigned-byte32) - (memref interrupted-esp 0 :type :unsigned-byte32) - (funobj-name casf-funobj)) - (when (eq 0 (stack-frame-ref stack frame -1)) - (break "X1 call in DIT-frame.")) - (map-region function (+ interrupted-esp 1) frame) - (setf next-frame frame - next-nether-frame (+ interrupted-esp 1 -2))) - ((let ((x1-tag (ldb (byte 3 0) - (memref interrupted-esp 4 :type :unsigned-byte8)))) - (and (member x1-tag '(1 5 6 7)) - (location-in-object-p casf-code-vector - (memref interrupted-esp 4 :type :location)))) - ;; When code-vector migration is implemented... - (warn "Scanning at ~S X1 call ~S in ~S." - (dit-frame-ref stack dit-frame :eip :unsigned-byte32) - (memref interrupted-esp 4 :type :unsigned-byte32) - (funobj-name casf-funobj)) - (when (eq 0 (stack-frame-ref stack frame -1)) - (break "X1 call in DIT-frame.")) - (map-region function (+ interrupted-esp 2) frame) - (setf next-frame frame - next-nether-frame (+ interrupted-esp 2 -2))) - (t ;; Situation i. Nothing special on stack, scavenge frame normally. - ;; (map-region function interrupted-esp frame) - (setf next-frame frame - next-nether-frame (- interrupted-esp 2)) - ))) - ((eq casf-frame (memref interrupted-esp 0 :type :location)) - ;; Situation ii. esp(0)=CASF, esp(1)=code-vector - (assert (location-in-object-p casf-code-vector - (memref interrupted-esp 4 :type :location)) - - () "Stack discipline situation ii. invariant broken. CASF=#x~X, ESP=~S, EBP=~S" - casf-frame interrupted-esp interrupted-ebp) - (when (eq 0 (stack-frame-ref stack frame -1)) - (break "X1 ii call in DIT-frame.")) - (map-region function (+ interrupted-esp 2) frame) - (setf next-frame frame - next-nether-frame (+ interrupted-esp 2 -2))) - (t ;; Situation iii. esp(0)=code-vector. - (assert (location-in-object-p casf-code-vector - (memref interrupted-esp 0 :type :location)) - () "Stack discipline situation iii. invariant broken. CASF=#x~X" - casf-frame) - (when (eq 0 (stack-frame-ref stack frame -1)) - (break "X1 iii call in DIT-frame.")) - (map-region function (+ interrupted-esp 1) frame) - (setf next-frame frame - next-nether-frame (+ interrupted-esp 1 -2)))))) - (t (error "DIT-frame interrupted unknown CASF funobj: ~Z, CASF ~S" - casf-funobj casf-frame)))))) - (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj))))))) - (values))

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp
by ffjeld＠common-lisp.net 27 Jan '05

27 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv30105 Modified Files: debugger.lisp Log Message: Tweaked *call-site-patterns*. Date: Thu Jan 27 03:19:55 2005 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.29 movitz/losp/x86-pc/debugger.lisp:1.30 --- movitz/losp/x86-pc/debugger.lisp:1.29 Fri Jan 21 13:02:45 2005 +++ movitz/losp/x86-pc/debugger.lisp Thu Jan 27 03:19:53 2005 @@ -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.29 2005/01/21 21:02:45 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.30 2005/01/27 11:19:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -225,7 +225,8 @@ (:* 1 ((:or ((:or (#x8b #x56 (:edx :esi)) ; (:movl (:esi x) :edx) (#x8b #x54 #x37 (:edx :esi+edi))) ;#<asm MOVL [#x39+%EDI+%ESI] => %EDX> #x8b #x72 #xfd) ; (:movl (:edx -3) :esi) - (#x8b #x74 #x7e (:any-offset))))) ; #<asm MOVL [#x28+%ESI+%EDI*2] => %ESI> + (#x8b #x74 #x7e (:any-offset)) ; #<asm MOVL [#x28+%ESI+%EDI*2] => %ESI> + (#x8b #x76 (:any-offset))))) ; #<asm MOVL [#x56+%ESI] => %ESI> (:* 1 ((:or (#xb1 (:cl-numargs))))) ; (:movb x :cl) (:* 1 ((:or (#x8b #x55 (:edx :ebp)) (#x8b #x56 (:edx :esi)))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp
by ffjeld＠common-lisp.net 27 Jan '05

27 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23073 Modified Files: scavenge.lisp Log Message: Fixed the situation when an interrupt occures inside dynamic-jump-next. Date: Thu Jan 27 01:01:27 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.42 movitz/losp/muerte/scavenge.lisp:1.43 --- movitz/losp/muerte/scavenge.lisp:1.42 Wed Jan 26 23:46:49 2005 +++ movitz/losp/muerte/scavenge.lisp Thu Jan 27 01:01:27 2005 @@ -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.42 2005/01/27 07:46:49 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.43 2005/01/27 09:01:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -199,9 +199,16 @@ ((match-funobj esi location)) ((not (typep casf-funobj 'function)) (break "Unknown funobj/frame-type: ~S" casf-funobj)) + ((location-in-object-p (%run-time-context-slot 'dynamic-jump-next) location) + (%run-time-context-slot 'dynamic-jump-next)) ((when searchp (%find-code-vector location))) - (t (error "Unable to decode EIP #x~X funobj ~S." location casf-funobj))))) + (t (with-simple-restart (continue "Try to perform a code-vector-search.") + (error "Unable to decode EIP #x~X funobj ~S, ESI ~S." + (* 4 location) casf-funobj esi)) + (or (%find-code-vector location) + (error "Code-vector-search for EIP #x~X also failed." + (* 4 location))))))) (defun map-stack-value (function value frame) (if (not (typep value 'pointer)) @@ -305,7 +312,6 @@ (eq x1-tag 3) ; 3 or 7? (and (oddp x1-location) (eq x1-tag 2))) ; 6? (location-in-object-p casf-code-vector x1-location)) - (warn "X1: ~S ~S" x1-location x1-tag) (let* ((old-x1-code-vector (scavenge-find-code-vector (stack-frame-ref nil next-eip-index 0 :location) casf-funobj interrupted-esi t)))

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 27 Jan '05

27 Jan '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv22622 Modified Files: compiler.lisp Log Message: Changed slightly the compiler protocol such that register-function-code-size is called also for internal functions. Date: Thu Jan 27 01:00:27 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.130 movitz/compiler.lisp:1.131 --- movitz/compiler.lisp:1.130 Tue Jan 25 05:42:39 2005 +++ movitz/compiler.lisp Thu Jan 27 01:00:25 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.130 2005/01/25 13:42:39 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.131 2005/01/27 09:00:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -169,7 +169,6 @@ (let ((old-size (gethash hash-name (function-code-sizes *image*)))) (cond ((not old-size)) - ((eq name :anonymous-lambda)) ((not *warn-function-change-p*)) ((> new-size old-size) (warn "~S grew from ~D to ~D bytes." name old-size new-size)) @@ -234,10 +233,9 @@ "~&;; While Movitz compiling ~S in ~A:" name muerte.cl:*compile-file-pathname*))))) (with-retries-until-true (retry-funobj "Retry compilation of ~S." name) - (register-function-code-size - (make-compiled-funobj-pass2 - (make-compiled-funobj-pass1 name lambda-list declarations - form env top-level-p :funobj funobj)))))) + (make-compiled-funobj-pass2 + (make-compiled-funobj-pass1 name lambda-list declarations + form env top-level-p :funobj funobj))))) (defun make-compiled-funobj-pass1 (name lambda-list declarations form env top-level-p &key funobj) @@ -709,9 +707,9 @@ do (let ((sub-funobj (function-binding-funobj function-binding))) ;; (warn "USage: ~S => ~S" sub-funobj usage) (case (car (movitz-funobj-name sub-funobj)) - (:anonymous-lambda + ((muerte.cl:lambda) (setf (movitz-funobj-name sub-funobj) - (list :anonymous-lambda + (list 'lambda (movitz-funobj-name toplevel-funobj) (post-incf sub-funobj-index))))) (loop for borrowed-binding in (borrowed-bindings sub-funobj) @@ -793,7 +791,7 @@ (t (complete-funobj-default funobj))) (loop for (sub-function-binding) on (sub-function-binding-usage funobj) by #'cddr do (complete-funobj (function-binding-funobj sub-function-binding))) - funobj) + (register-function-code-size funobj)) (defun complete-funobj-1req1opt (funobj) (assert (= 2 (length (function-envs funobj))))

1 0

[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
by ffjeld＠common-lisp.net 27 Jan '05

27 Jan '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv22332 Modified Files: special-operators-cl.lisp Log Message: Call anonymous functions (lambda <parent> <number>) rather than (:anonymous-lambda ...) Date: Thu Jan 27 00:58:53 2005 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.43 movitz/special-operators-cl.lisp:1.44 --- movitz/special-operators-cl.lisp:1.43 Tue Jan 25 05:44:11 2005 +++ movitz/special-operators-cl.lisp Thu Jan 27 00:58:53 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.43 2005/01/25 13:44:11 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.44 2005/01/27 08:58:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1014,7 +1014,7 @@ (multiple-value-bind (lambda-forms lambda-declarations) (parse-docstring-declarations-and-body (cddr name)) (let ((lambda-funobj - (make-compiled-funobj-pass1 '(:anonymous-lambda) + (make-compiled-funobj-pass1 '(muerte.cl:lambda) (cadr name) lambda-declarations `(muerte.cl:progn ,@lambda-forms)

1 0

[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp
by ffjeld＠common-lisp.net 27 Jan '05

27 Jan '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv18946 Modified Files: los0-gc.lisp Log Message: If a recursive GC is triggered, try to be slightly clever and allocate a new space that can be used by the debugger. Date: Wed Jan 26 23:48:53 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.47 movitz/losp/los0-gc.lisp:1.48 --- movitz/losp/los0-gc.lisp:1.47 Wed Jan 26 05:49:24 2005 +++ movitz/losp/los0-gc.lisp Wed Jan 26 23:48:53 2005 @@ -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.47 2005/01/26 13:49:24 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.48 2005/01/27 07:48:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,18 +25,6 @@ (defvar *gc-consitency-check* t) -(defun make-space (location size) - "Make a space vector at a fixed location." - (assert (evenp location)) - (macrolet ((x (index) - `(memref location 0 :index ,index :type :unsigned-byte32))) - (setf (x 1) (* #.movitz:+movitz-fixnum-factor+ size) - (x 0) #.(cl:dpb (bt:enum-value 'movitz:movitz-vector-element-type :u32) - (cl:byte 8 8) - (bt:enum-value 'movitz:other-type-byte :basic-vector)))) - (%word-offset location #.(movitz:tag :other))) - - (defmacro space-fresh-pointer (space) `(memref ,space -6 :index 2)) @@ -59,8 +47,32 @@ (setf (space-other space1) space2) space1)) -;;;(defun space-cons-pointer () -;;; (aref (%run-time-context-slot 'nursery-space) 0)) +(defun make-space (location size) + "Make a space vector at a fixed location." + (assert (evenp location)) + (macrolet ((x (index) + `(memref location 0 :index ,index :type :unsigned-byte32))) + (setf (x 1) (* #.movitz:+movitz-fixnum-factor+ size) + (x 0) #.(cl:dpb (bt:enum-value 'movitz:movitz-vector-element-type :u32) + (cl:byte 8 8) + (bt:enum-value 'movitz:other-type-byte :basic-vector)))) + (%word-offset location #.(movitz:tag :other))) + +(defun make-duo-space (location size) + (when (oddp location) + (incf location)) + (let ((space1 (make-space location size)) + (space2 (make-space (logand -4 (+ location 3 size)) size))) + (initialize-space space1) + (initialize-space space2) + (setf (space-other space1) space2 + (space-other space2) space1) + space1)) + +(defun duo-space-end-location (space1) + (let ((space2 (space-other space1))) + (max (+ (object-location space1) (length space2) 2) + (+ (object-location space2) (length space2) 2)))) (defun test () (warn "install..") @@ -229,12 +241,17 @@ (declare (ignore exception interrupt-frame)) (without-interrupts (let ((*standard-output* *terminal-io*)) - (when *gc-running* - (break "Recursive GC triggered.")) - (let ((*gc-running* t)) - (unless *gc-quiet* - (format t "~&;; GC.. ")) - (stop-and-copy)) + (cond + (*gc-running* + (let* ((full-space (%run-time-context-slot 'muerte::nursery-space)) + (hack-space (make-duo-space (duo-space-end-location full-space) 102400))) + (setf (%run-time-context-slot 'muerte::nursery-space) hack-space) + (break "Recursive GC triggered. Full-space: ~Z, hack-space: ~Z" + full-space hack-space))) + (t (let ((*gc-running* t)) + (unless *gc-quiet* + (format t "~&;; GC.. ")) + (stop-and-copy)))) (if *gc-break* (break "GC break.") (loop ; This is a nice opportunity to poll the keyboard.. @@ -429,9 +446,9 @@ (unless *gc-quiet* (let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2)) (new-size (truncate (- (space-fresh-pointer newspace) 2) 2))) - (format t "Old space [~Z]: ~/muerte:pprint-clumps/, new space [~Z]: ~ + (format t "Old space: ~/muerte:pprint-clumps/, new space: ~ ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%" - oldspace old-size newspace new-size (- old-size new-size)))) + old-size new-size (- old-size new-size)))) (initialize-space oldspace) (fill oldspace #x13 :start 2)

1 0