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

[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

[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