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

[movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.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-serv18929 Modified Files: basic-functions.lisp Log Message: Removed some dead code. Date: Wed Jan 26 23:47:37 2005 Author: ffjeld Index: movitz/losp/muerte/basic-functions.lisp diff -u movitz/losp/muerte/basic-functions.lisp:1.15 movitz/losp/muerte/basic-functions.lisp:1.16 --- movitz/losp/muerte/basic-functions.lisp:1.15 Mon Dec 20 02:51:52 2004 +++ movitz/losp/muerte/basic-functions.lisp Wed Jan 26 23:47:37 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.15 2004/12/20 10:51:52 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.16 2005/01/27 07:47:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -349,18 +349,6 @@ (defun object-tag (object) (object-tag object)) - -;;;(define-compiler-macro object-location-offset (object) -;;; "The offset from the object's location to it's true address." -;;; `(with-inline-assembly (:returns :register) -;;; (:compile-form (:result-mode :register) ,object) -;;; (:shll ,movitz:+movitz-fixnum-shift+ (:result-register)) -;;; (:andl ,(* movitz:+movitz-fixnum-factor+ -;;; movitz:+movitz-fixnum-zmask+) -;;; (:result-register)))) -;;; -;;;(defun object-location-offset (object) -;;; (object-location-offset object)) (defun halt-cpu () (halt-cpu))

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-serv18901 Modified Files: scavenge.lisp Log Message: Forgot an argument for match-funobj. Date: Wed Jan 26 23:46:51 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.41 movitz/losp/muerte/scavenge.lisp:1.42 --- movitz/losp/muerte/scavenge.lisp:1.41 Wed Jan 26 05:46:14 2005 +++ movitz/losp/muerte/scavenge.lisp Wed Jan 26 23:46:49 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.41 2005/01/26 13:46:14 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.42 2005/01/27 07:46:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -193,7 +193,7 @@ (cond ((location-in-object-p dit-code-vector location) dit-code-vector) - ((match-funobj esi)) + ((match-funobj esi location)) (t (break "DIT returns outside DIT??"))))) ((match-funobj casf-funobj location)) ((match-funobj esi location))

1 0

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

26 Jan '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv27181 Modified Files: los0-gc.lisp Log Message: Debugging tweaks: Don't trigger-newspace when *gc-running*. Added function report-lispval. Date: Wed Jan 26 05:49:24 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.46 movitz/losp/los0-gc.lisp:1.47 --- movitz/losp/los0-gc.lisp:1.46 Tue Jan 25 05:56:14 2005 +++ movitz/losp/los0-gc.lisp Wed Jan 26 05:49:24 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.46 2005/01/25 13:56:14 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.47 2005/01/26 13:49:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -102,40 +102,41 @@ (defun trigger-full-newspace (free-space) "Make it so that there's only free-space words left before newspace is full." - (let ((trigger (if (consp *gc-trigger*) - (pop *gc-trigger*) - *gc-trigger*))) - (when trigger - (macrolet - ((do-it () - `(with-inline-assembly (:returns :nothing) - retry - (:compile-form (:result-mode :eax) (+ free-space trigger)) - (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) - (:testl ,(logxor #xffffffff - (* #xfff movitz:+movitz-fixnum-factor+)) - :eax) - (:jnz '(:sub-program () (:int 64))) - (:addl 4 :eax) - (:andl -8 :eax) - (:movl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) - :ecx) - (:subl :eax :ecx) - (:movl (:edx 2) :ebx) - (:cmpl :ecx :ebx) - (:jc '(:sub-program () - ;; Current newspace was too full, so trigger a GC. - (:int 113) - (:jmp 'retry))) - (:movl :ecx (:edx 2)) - (:addl 8 :ebx) - fill-loop - (:movl :edi (:edx :ebx -6)) - (:addl 4 :ebx) - (:cmpl :ebx :ecx) - (:ja 'fill-loop) - ))) - (do-it))))) + (unless *gc-running* + (let ((trigger (if (consp *gc-trigger*) + (pop *gc-trigger*) + *gc-trigger*))) + (when trigger + (macrolet + ((do-it () + `(with-inline-assembly (:returns :nothing) + retry + (:compile-form (:result-mode :eax) (+ free-space trigger)) + (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) + (:testl ,(logxor #xffffffff + (* #xfff movitz:+movitz-fixnum-factor+)) + :eax) + (:jnz '(:sub-program () (:int 64))) + (:addl 4 :eax) + (:andl -8 :eax) + (:movl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) + :ecx) + (:subl :eax :ecx) + (:movl (:edx 2) :ebx) + (:cmpl :ecx :ebx) + (:jc '(:sub-program () + ;; Current newspace was too full, so trigger a GC. + (:int 113) + (:jmp 'retry))) + (:movl :ecx (:edx 2)) + (:addl 8 :ebx) + fill-loop + (:movl :edi (:edx :ebx -6)) + (:addl 4 :ebx) + (:cmpl :ebx :ecx) + (:ja 'fill-loop) + ))) + (do-it)))))) (define-primitive-function los0-cons-pointer () @@ -156,7 +157,7 @@ (:ja '(:sub-program (probe-failed) (:int 113) (:int 63))) - (:movl :edi (:edx :ebx 8 ,movitz:+other-type-offset+)) + (:movl #xabbabee3 (:edx :ebx 8 ,movitz:+other-type-offset+)) ; a recognizable illegal value? (:leal (:edx :ebx 8) :eax) (:ret)))) (do-it))) @@ -405,6 +406,7 @@ (break "Seeing old object in values-vector: ~Z" x)) x) #x38 #xb8) + #+ignore (let* ((stack (%run-time-context-slot 'muerte::stack-vector)) (stack-start (- (length stack) (muerte::current-control-stack-depth)))) (do ((i 0 (+ i 3))) @@ -417,9 +419,6 @@ (+ (object-location stack) offender-index 2) (aref a (+ i 2)))))) - (loop for x from 0 to #xa0000 - do (when (= #x19a04e (memref x 0 :type :unsigned-byte32)) - (warn "Seeing foo at ~S." x))) (loop for i from stack-start below (length stack) as o = (aref stack i) do (when (and (typep o 'pointer) @@ -433,6 +432,7 @@ (format t "Old space [~Z]: ~/muerte:pprint-clumps/, new space [~Z]: ~ ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%" oldspace old-size newspace new-size (- old-size new-size)))) + (initialize-space oldspace) (fill oldspace #x13 :start 2) ;; (setf *gc-stack2* *gc-stack*) @@ -471,3 +471,16 @@ (+ 4 (object-location nursery) (space-fresh-pointer nursery)))) (map-stack-vector #'searcher nil (current-stack-frame)))) results)) + +(defun report-lispval (lispval &optional breakp newspace) + (let* ((location (truncate lispval 4)) + (newspace (or newspace (%run-time-context-slot 'muerte::nursery-space))) + (oldspace (space-other newspace))) + (cond + ((location-in-object-p newspace location) + (format t "#x~X is in newspace ~Z." lispval newspace)) + ((location-in-object-p oldspace location) + (funcall (if breakp 'break 'warn) "#x~X is in oldspace ~Z." lispval oldspace)) + (t (funcall (if breakp 'break 'warn) "#x~X is neither old nor new?" lispval)))) + (values)) +

1 0

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

26 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27148 Modified Files: scavenge.lisp Log Message: In scavenge-find-code-vector, fixed the situation when the DIT shared an inclomplete stack-frame with the handler. Date: Wed Jan 26 05:46:14 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.40 movitz/losp/muerte/scavenge.lisp:1.41 --- movitz/losp/muerte/scavenge.lisp:1.40 Tue Jan 25 05:56:18 2005 +++ movitz/losp/muerte/scavenge.lisp Wed Jan 26 05:46:14 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.40 2005/01/25 13:56:18 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.41 2005/01/26 13:46:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -168,23 +168,11 @@ (+ start-frame 1) map-region)) -;;;(defun map-code-vector-slot (function stack slot casf-funobj) -;;; (let ((casf-code-vector (if (eq 0 casf-funobj) -;;; (symbol-value 'default-interrupt-trampoline) -;;; (funobj-code-vector casf-funobj))) -;;; (eip-location (stack-frame-ref stack slot 0 :location))) -;;; (cond -;;; ((location-in-object-p casf-code-vector eip-location) -;;; (let ((new (funcall function casf-code-vector nil))) -;;; (when (not (eq new casf-code-vector)) -;;; ;; Perform some pointer arithmetics.. -;;; (let ((offset (- (stack-frame-ref stack slot 0 :unsigned-byte32) -;;; (%object-lispval casf-code-vector)))) -;;; (break "Code-vector for ~S moved, offset is ~D." casf-code-vector offset)))))))) - (defun scavenge-find-code-vector (location casf-funobj esi &optional searchp) (flet ((match-funobj (funobj location) (cond + ((not (typep funobj 'function)) + nil) ((let ((x (funobj-code-vector casf-funobj))) (and (location-in-object-p x location) x))) ((let ((x (funobj-code-vector%1op casf-funobj))) @@ -202,12 +190,13 @@ (cond ((eq 0 casf-funobj) (let ((dit-code-vector (symbol-value 'default-interrupt-trampoline))) - (if (location-in-object-p dit-code-vector location) - dit-code-vector - (break "DIT returns outside DIT??")))) - ((and (typep esi 'function) - (match-funobj esi location))) + (cond + ((location-in-object-p dit-code-vector location) + dit-code-vector) + ((match-funobj esi)) + (t (break "DIT returns outside DIT??"))))) ((match-funobj casf-funobj location)) + ((match-funobj esi location)) ((not (typep casf-funobj 'function)) (break "Unknown funobj/frame-type: ~S" casf-funobj)) ((when searchp @@ -275,6 +264,7 @@ (= 0 (ldb (byte 2 0) atomically))) ;; Interrupt occurred inside an (non-pf) atomically, so none of the ;; GC-root registers are active. + #+ignore (setf (dit-frame-ref nil dit-frame :eax) nil (dit-frame-ref nil dit-frame :ebx) nil (dit-frame-ref nil dit-frame :edx) nil

1 0

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

25 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17178 Modified Files: scavenge.lisp Log Message: Re-working the stack discipline/scavenging strategy. Still not quite there, but it seems close. Date: Tue Jan 25 05:56:19 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.39 movitz/losp/muerte/scavenge.lisp:1.40 --- movitz/losp/muerte/scavenge.lisp:1.39 Tue Jan 4 08:54:27 2005 +++ movitz/losp/muerte/scavenge.lisp Tue Jan 25 05:56: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.39 2005/01/04 16:54:27 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.40 2005/01/25 13:56:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -36,7 +36,7 @@ (loop for location from start-location below end-location as object = (memref location 0) do (when (typep object 'pointer) - (let ((new-object (do-map object))) + (let ((new-object (do-map object location))) (unless (eq object new-object) (setf (memref location 0) new-object))))))) @@ -139,7 +139,7 @@ #.(bt:enum-value 'movitz:movitz-vector-element-type :any-t)) (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (error "Scanned unknown basic-vector-header ~S at location #x~X." x scan))) - ((eq x 3) + ((and (eq x 3) (eq x2 0)) (setf *scan-last* scan) (incf scan) (let ((delta (memref scan 0))) @@ -147,17 +147,208 @@ ;; (warn "at ~S skipping ~S to ~S." scan delta (+ scan delta)) (incf scan delta))) (t ;; (typep x 'pointer) - (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))))))))) + (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)) "Map function over the potential pointer words of a stack, starting at the start-stack-frame location." + (assert (typep (stack-frame-funobj stack start-frame) 'function) (start-frame) + "Cannot start map-stack-vector at a non-normal frame.") + (assert (eq nil stack)) + (map-stack function + (stack-frame-uplink stack start-frame) + (+ start-frame 2) + (+ start-frame 1) + map-region)) + +;;;(defun map-code-vector-slot (function stack slot casf-funobj) +;;; (let ((casf-code-vector (if (eq 0 casf-funobj) +;;; (symbol-value 'default-interrupt-trampoline) +;;; (funobj-code-vector casf-funobj))) +;;; (eip-location (stack-frame-ref stack slot 0 :location))) +;;; (cond +;;; ((location-in-object-p casf-code-vector eip-location) +;;; (let ((new (funcall function casf-code-vector nil))) +;;; (when (not (eq new casf-code-vector)) +;;; ;; Perform some pointer arithmetics.. +;;; (let ((offset (- (stack-frame-ref stack slot 0 :unsigned-byte32) +;;; (%object-lispval casf-code-vector)))) +;;; (break "Code-vector for ~S moved, offset is ~D." casf-code-vector offset)))))))) + +(defun scavenge-find-code-vector (location casf-funobj esi &optional searchp) + (flet ((match-funobj (funobj location) + (cond + ((let ((x (funobj-code-vector casf-funobj))) + (and (location-in-object-p x location) x))) + ((let ((x (funobj-code-vector%1op casf-funobj))) + (and (typep x 'vector) + (location-in-object-p x location) + x))) + ((let ((x (funobj-code-vector%2op casf-funobj))) + (and (typep x 'vector) + (location-in-object-p x location) + x))) + ((let ((x (funobj-code-vector%3op casf-funobj))) + (and (typep x 'vector) + (location-in-object-p x location) + x)))))) + (cond + ((eq 0 casf-funobj) + (let ((dit-code-vector (symbol-value 'default-interrupt-trampoline))) + (if (location-in-object-p dit-code-vector location) + dit-code-vector + (break "DIT returns outside DIT??")))) + ((and (typep esi 'function) + (match-funobj esi location))) + ((match-funobj casf-funobj location)) + ((not (typep casf-funobj 'function)) + (break "Unknown funobj/frame-type: ~S" casf-funobj)) + ((when searchp + (%find-code-vector location))) + (t (error "Unable to decode EIP #x~X funobj ~S." location casf-funobj))))) + +(defun map-stack-value (function value frame) + (if (not (typep value 'pointer)) + value + (funcall function value frame))) + +(defun map-stack (function frame frame-bottom eip-index map-region) + (with-funcallable (map-region) + (loop + ;; for frame = frame then (stack-frame-uplink frame) + ;; as frame-end = frame-end then frame + while (not (eq 0 frame)) + do (map-lisp-vals function (1- frame) frame) + (let ((frame-funobj (map-stack-value function (stack-frame-funobj nil frame) frame))) + (cond + ((eq 0 frame-funobj) + (return (map-stack-dit function frame frame-bottom eip-index map-region))) + ((not (typep frame-funobj 'function)) + (error "Unknown stack-frame funobj ~S at ~S" frame-funobj frame)) + (t (let* ((old-code-vector + (scavenge-find-code-vector (stack-frame-ref nil eip-index 0 :location) + frame-funobj nil nil))) + (map-stack-instruction-pointer function eip-index old-code-vector)) + (let ((raw-locals (funobj-frame-raw-locals frame-funobj))) + (if (= 0 raw-locals) + (map-region function frame-bottom frame) + (progn + (break "~D raw-locals for ~S?" raw-locals frame-funobj) + (map-region function (1- frame) frame) + (map-region function frame-bottom (- frame 1 raw-locals)))) + (setf eip-index (+ frame 1) + frame-bottom (+ frame 2) + frame (stack-frame-uplink nil frame))))))))) + +(defun test-stack () + (let ((z (current-stack-frame))) + (map-stack (lambda (x y) + (format t "~&[~S]: ~S" y x) + x) + (stack-frame-uplink nil z) (+ z 2) (+ z 1) + #'map-header-vals))) + +(defun map-stack-dit (function dit-frame frame-bottom eip-index map-region) + (with-funcallable (map-region) + (let* ((atomically + (dit-frame-ref nil dit-frame :atomically-continuation :unsigned-byte32)) + (secondary-register-mode-p + (logbitp 10 (dit-frame-ref nil dit-frame :eflags :unsigned-byte32))) + (casf-frame + (dit-frame-casf nil dit-frame)) + (casf-funobj (map-stack-value function (stack-frame-funobj nil casf-frame) casf-frame)) + (casf-code-vector (map-stack-value function + (case casf-funobj + (0 (symbol-value 'default-interrupt-trampoline)) + (t (funobj-code-vector casf-funobj))) + casf-frame))) + ;; 1. Scavenge the dit-frame + (cond + ((and (not (= 0 atomically)) + (= 0 (ldb (byte 2 0) atomically))) + ;; Interrupt occurred inside an (non-pf) atomically, so none of the + ;; GC-root registers are active. + (setf (dit-frame-ref nil dit-frame :eax) nil + (dit-frame-ref nil dit-frame :ebx) nil + (dit-frame-ref nil dit-frame :edx) nil + (dit-frame-ref nil dit-frame :esi) nil) + (map-region function frame-bottom (+ dit-frame 1 (dit-frame-index :scratch1)))) + (secondary-register-mode-p + ;; EBX is also active + (map-region function frame-bottom (+ dit-frame 1 (dit-frame-index :ebx)))) + (t ;; EDX and EAX too. + (map-region function frame-bottom (+ dit-frame 1 (dit-frame-index :eax))))) + ;; The DIT's return-address + (let* ((interrupted-esi (dit-frame-ref nil dit-frame :esi)) + (next-frame-bottom (+ dit-frame 1 (dit-frame-index :eflags))) + (next-eip-index (+ dit-frame (dit-frame-index :eip))) + (old-code-vector + (scavenge-find-code-vector (stack-frame-ref nil eip-index 0 :location) + 0 interrupted-esi + nil)) + (new-code-vector (map-stack-instruction-pointer function eip-index old-code-vector))) + ;; + (multiple-value-bind (x0-location x0-tag) + (stack-frame-ref nil next-frame-bottom 0 :signed-byte30+2) + ;; (warn "X0: ~S ~S" x0-location x0-tag) + (cond + ((and (or (eq x0-tag 1) ; 1 or 5? + (eq x0-tag 3) ; 3 or 7? + (and (oddp x0-location) (eq x0-tag 2))) ; 6? + (location-in-object-p casf-code-vector x0-location)) + (let* ((old-x0-code-vector + (scavenge-find-code-vector (stack-frame-ref nil next-eip-index 0 :location) + casf-funobj interrupted-esi t))) + (map-stack-instruction-pointer function next-eip-index old-x0-code-vector)) + (setf next-eip-index next-frame-bottom + next-frame-bottom (1+ next-frame-bottom))) + (t (multiple-value-bind (x1-location x1-tag) + (stack-frame-ref nil next-frame-bottom 1 :signed-byte30+2) + (when (and (or (eq x1-tag 1) ; 1 or 5? + (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))) + (map-stack-instruction-pointer function next-eip-index old-x1-code-vector)) + (setf next-eip-index (+ 1 next-frame-bottom) + next-frame-bottom (+ 2 next-frame-bottom))))))) + ;; proceed + (map-stack function casf-frame next-frame-bottom next-eip-index map-region))))) + +(defun map-stack-instruction-pointer (function index old-code-vector) + "Update the (raw) instruction-pointer in stack at index, +assuming the pointer refers to old-code-vector." + (assert (location-in-object-p old-code-vector (stack-frame-ref nil index 0 :location))) + (let ((new-code-vector (funcall function old-code-vector nil))) + (when (not (eq old-code-vector new-code-vector)) + (break "Code-vector for stack instruction-pointer moved. [index: ~S]" index)) + new-code-vector)) + +(defun map-stack-flaccid-pointer (function index) + "If the pointed-to object is moved, reset pointer to NIL." + (let ((old (stack-frame-ref nil index 0))) + (cond + ((not (typep old 'pointer)) + old) + ((eq old (funcall function old index)) + 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) @@ -176,7 +367,7 @@ (incf nether-frame 4)) (typecase funobj ((or function null) - (assert (= 0 (funobj-frame-num-unboxed funobj))) + (assert (= 0 (funobj-frame-raw-locals funobj))) (map-region function (+ nether-frame 2) frame)) ((eql 0) ; A dit interrupt-frame? (let* ((dit-frame frame) @@ -210,10 +401,6 @@ (interrupted-ebp (dit-frame-ref stack dit-frame :ebp)) (casf-funobj (funcall function (stack-frame-funobj stack frame) frame))) (cond - #+ignore - ((eq nil casf-funobj) - (warn "Scanning interrupt in PF: ~S" - (dit-frame-ref stack dit-frame :eip :unsigned-byte32))) ((or (eq 0 casf-funobj) (typep casf-funobj 'function)) (let ((casf-code-vector (scavenge-funobj-code-vector casf-funobj)))

1 0

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

25 Jan '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv17162 Modified Files: los0-gc.lisp Log Message: Re-working the stack discipline/scavenging strategy. Still not quite there, but it seems close. Date: Tue Jan 25 05:56:14 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.45 movitz/losp/los0-gc.lisp:1.46 --- movitz/losp/los0-gc.lisp:1.45 Wed Dec 8 15:39:51 2004 +++ movitz/losp/los0-gc.lisp Tue Jan 25 05:56:14 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2003-2004, +;;;; Copyright (C) 2003-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -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.45 2004/12/08 23:39:51 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.46 2005/01/25 13:56:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -109,6 +109,7 @@ (macrolet ((do-it () `(with-inline-assembly (:returns :nothing) + retry (:compile-form (:result-mode :eax) (+ free-space trigger)) (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) (:testl ,(logxor #xffffffff @@ -121,6 +122,11 @@ :ecx) (:subl :eax :ecx) (:movl (:edx 2) :ebx) + (:cmpl :ecx :ebx) + (:jc '(:sub-program () + ;; Current newspace was too full, so trigger a GC. + (:int 113) + (:jmp 'retry))) (:movl :ecx (:edx 2)) (:addl 8 :ebx) fill-loop @@ -138,7 +144,6 @@ (macrolet ((do-it () `(with-inline-assembly (:returns :multiple-values) - retry (:locally (:cmpl 0 (:edi (:edi-offset atomically-continuation)))) ; Atomically? (:je '(:sub-program () (:int 63))) ; This must be called inside atomically. @@ -151,8 +156,8 @@ (:ja '(:sub-program (probe-failed) (:int 113) (:int 63))) - (:leal (:edx :ebx 8) :eax) (:movl :edi (:edx :ebx 8 ,movitz:+other-type-offset+)) + (:leal (:edx :ebx 8) :eax) (:ret)))) (do-it))) @@ -162,7 +167,6 @@ (macrolet ((do-it () `(with-inline-assembly (:returns :multiple-values) - retry (:locally (:cmpl 0 (:edi (:edi-offset atomically-continuation)))) ; Atomically? (:je '(:sub-program () (:int 63))) ; This must be called inside atomically. @@ -174,7 +178,7 @@ :ecx) (:ja '(:sub-program (commit-failed) (:int 113) - (:jmp 'retry))) + (:int 63))) (:movl :ecx (:edx 2)) (:leal (:edx :ecx) :ecx) (:ret)))) @@ -190,7 +194,6 @@ (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax) (:ret) not-fixnum - retry-cons (:locally (:movl ,(movitz::atomically-continuation-simple-pf 'box-u32-ecx) (:edi (:edi-offset atomically-continuation)))) (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) @@ -211,7 +214,8 @@ (:ret)))) (do-it))) -(defvar *gc-stack*) +(defvar *gc-stack* nil) +(defvar *gc-stack2* nil) (defun install-los0-consing (&key (context (current-run-time-context)) (kb-size 1024) @@ -401,23 +405,37 @@ (break "Seeing old object in values-vector: ~Z" x)) x) #x38 #xb8) - (let* ((stack (%run-time-context-slot 'muerte::nursery-space)) + (let* ((stack (%run-time-context-slot 'muerte::stack-vector)) (stack-start (- (length stack) (muerte::current-control-stack-depth)))) (do ((i 0 (+ i 3))) ((>= i (length a))) - (when (find (aref a i) stack :start stack-start) - (break "Seeing old object ~S in current stack!" - (aref a i)))))))) - + (let* ((offender? (aref a i)) + (offender-index (position offender? stack :start stack-start))) + (when offender-index + (break "Seeing old object ~S in current stack at ~S, new is ~S" + offender? + (+ (object-location stack) + offender-index 2) + (aref a (+ i 2)))))) + (loop for x from 0 to #xa0000 + do (when (= #x19a04e (memref x 0 :type :unsigned-byte32)) + (warn "Seeing foo at ~S." x))) + (loop for i from stack-start below (length stack) + as o = (aref stack i) + do (when (and (typep o 'pointer) + (location-in-object-p oldspace (object-location o))) + (break "Seeing old (unmapped) object ~Z in stack at ~S." + o (+ (object-location stack) i 2)))))))) ;; GC completed, oldspace is evacuated. (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: ~/muerte:pprint-clumps/, new space: ~ + (format t "Old space [~Z]: ~/muerte:pprint-clumps/, new space [~Z]: ~ ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%" - old-size new-size (- old-size new-size)))) + oldspace old-size newspace new-size (- old-size new-size)))) (initialize-space oldspace) (fill oldspace #x13 :start 2) + ;; (setf *gc-stack2* *gc-stack*) (setf *gc-stack* (muerte::copy-current-control-stack)) (setf (fill-pointer *xx*) (fill-pointer *x*)) (replace *xx* *x*)))

1 0

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

25 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17128 Modified Files: typep.lisp Log Message: Added (typep x 'unbound-value). Date: Tue Jan 25 05:55:36 2005 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.40 movitz/losp/muerte/typep.lisp:1.41 --- movitz/losp/muerte/typep.lisp:1.40 Mon Dec 13 03:25:41 2004 +++ movitz/losp/muerte/typep.lisp Tue Jan 25 05:55:36 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2000-2004, +;;;; Copyright (C) 2000-2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: typep.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.40 2004/12/13 11:25:41 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.41 2005/01/25 13:55:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -261,6 +261,10 @@ (make-basic-vector-typep :u32)) (code-vector (make-basic-vector-typep :code)) + (unbound-value + `(with-inline-assembly (:returns :boolean-overflow) + (:compile-form (:result-mode :eax) ,object) + (:cmpl -1 :eax))) (run-time-context (make-other-typep :run-time-context)) (structure-object

1 0

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

25 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17058 Modified Files: primitive-functions.lisp Log Message: Minor edit. Date: Tue Jan 25 05:54:57 2005 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.60 movitz/losp/muerte/primitive-functions.lisp:1.61 --- movitz/losp/muerte/primitive-functions.lisp:1.60 Mon Jan 10 00:19:06 2005 +++ movitz/losp/muerte/primitive-functions.lisp Tue Jan 25 05:54:57 2005 @@ -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.60 2005/01/10 08:19:06 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.61 2005/01/25 13:54:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -482,11 +482,10 @@ (:movl (:eax #.(movitz::class-object-offset 'symbol)) :eax) (:ret))) - (define-primitive-function fast-class-of-std-instance () "Return the class of a std-instance object." (with-inline-assembly (:returns :multiple-values) - (:movl (:eax #.(bt:slot-offset 'movitz::movitz-std-instance 'movitz::class)) + (:movl (:eax (:offset movitz-std-instance class)) :eax) (:ret)))

1 0

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

25 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16960 Modified Files: los-closette.lisp Log Message: *** empty log message *** Date: Tue Jan 25 05:52:26 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.25 movitz/losp/muerte/los-closette.lisp:1.26 --- movitz/losp/muerte/los-closette.lisp:1.25 Tue Jan 4 12:23:16 2005 +++ movitz/losp/muerte/los-closette.lisp Tue Jan 25 05:52:25 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.25 2005/01/04 20:23:16 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.26 2005/01/25 13:52:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1004,6 +1004,7 @@ (defclass illegal-object (t) () (:metaclass built-in-class)) (defclass infant-object (t) () (:metaclass built-in-class)) +(defclass unbound-value (t) () (:metaclass built-in-class)) (defclass run-time-context (t) ()

1 0

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

25 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16914 Modified Files: memref.lisp Log Message: *** empty log message *** Date: Tue Jan 25 05:51:36 2005 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.41 movitz/losp/muerte/memref.lisp:1.42 --- movitz/losp/muerte/memref.lisp:1.41 Mon Jan 10 06:04:52 2005 +++ movitz/losp/muerte/memref.lisp Tue Jan 25 05:51:36 2005 @@ -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.41 2005/01/10 14:04:52 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.42 2005/01/25 13:51:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -224,7 +224,7 @@ ,@fix-ecx)) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) - (with-inline-assembly (:returns :ecx :type (unsigned-byte 29)) + (with-inline-assembly (:returns :multiple-values) (:compile-two-forms (:ecx :ebx) ,offset ,index) (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) (:load-lexical (:lexical-binding ,object-var) :eax) @@ -411,9 +411,9 @@ ((:big) (memref object offset :index index :type :unsigned-byte16 :endian :big)))) (:code-vector (memref object offset :index index :type :code-vector)) - (:unsigned-byte14 (memref object offset :index index :type :unsigned-byte14)))) -;;; (:signed-byte30+2 (memref object offset index :signed-byte30+2)) -;;; (:unsigned-byte29+3 (memref object offset index :unsigned-byte29+3)))) + (:unsigned-byte14 (memref object offset :index index :type :unsigned-byte14)) + (:signed-byte30+2 (memref object offset :index index :type :signed-byte30+2)) + (:unsigned-byte29+3 (memref object offset :index index :type :unsigned-byte29+3)))) (define-compiler-macro (setf memref) (&whole form &environment env value object offset &key (index 0) (type :lisp) (localp nil) (endian :host)) @@ -963,7 +963,7 @@ (:movl :ecx (:eax ,offset))))))) (:lisp (assert (= 4 movitz:+movitz-fixnum-factor+)) - `(with-inline-assembly (:returns :untagged-fixnum-eax) + `(with-inline-assembly (:returns :eax) (:compile-form (:result-mode :push) ,address) (:compile-form (:result-mode :push) ,index) (:compile-form (:result-mode :push) ,offset) @@ -975,7 +975,7 @@ (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) (,prefixes :movl :eax (:ecx :ebx)))) (:unsigned-byte8 - `(with-inline-assembly (:returns :untagged-fixnum-eax) + `(with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :push) ,address) (:compile-form (:result-mode :push) ,index) (:compile-form (:result-mode :push) ,offset) @@ -983,11 +983,11 @@ (:popl :edx) ; offset (:popl :ebx) ; index (:popl :ecx) ; address - (:shrl ,movitz::+movitz-fixnum-shift+ :eax) + (:shll ,(- 8 movitz::+movitz-fixnum-shift+) :eax) (:addl :ebx :ecx) (:addl :edx :ecx) (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) - (,prefixes :movb :al (:ecx)))) + (,prefixes :movb :ah (:ecx)))) (:unsigned-byte16 (cond ((eq 0 offset)

1 0