Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv28476

Modified Files: los0-gc.lisp Log Message: Added los0-malloc-data-clumps, so that the los0 GC architecture now don't initialize non-pointer memory.

Date: Fri Apr 16 10:44:42 2004 Author: ffjeld

Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.9 movitz/losp/los0-gc.lisp:1.10 --- movitz/losp/los0-gc.lisp:1.9 Thu Apr 15 11:23:31 2004 +++ movitz/losp/los0-gc.lisp Fri Apr 16 10:44:42 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.9 2004/04/15 15:23:31 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.10 2004/04/16 14:44:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -54,7 +54,7 @@ (defun space-cons-pointer () (aref (%run-time-context-slot 'nursery-space) 0))

-(define-primitive-function new-fast-cons () +(define-primitive-function los0-fast-cons () "Allocate a cons cell from nursery-space." (with-inline-assembly (:returns :eax) retry-cons @@ -72,29 +72,46 @@ (:movl :ecx (:edx 2)) (:ret)))

-(defun new-malloc-clumps (clumps) - (check-type clumps (integer 0 1000)) - (with-inline-assembly (:returns :ebx) +(defun los0-malloc-clumps (clumps) + (check-type clumps (integer 0 4000)) + (with-inline-assembly (:returns :eax) retry - (:compile-form (:result-mode :eax) clumps) + (:compile-form (:result-mode :ebx) clumps) (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) (:movl (:edx 2) :ecx) - (:leal (:edx :ecx 8) :ebx) - (:leal ((:eax 2) :ecx) :ecx) - (:cmpl #x3fff4 :ecx) + (:leal ((:ebx 2) :ecx) :eax) + (:cmpl #x3fff4 :eax) (:jge '(:sub-program () (:compile-form (:result-mode :ignore) (stop-and-copy)) (:jmp 'retry))) - (:movl :ecx (:edx 2)) + (:movl :eax (:edx 2)) + (:movl #.(movitz:tag :infant-object) (:edx :ecx 6)) + (:leal (:edx :ecx 8) :eax) (:xorl :ecx :ecx) init-loop ; Now init eax number of clumps. - (:movl :edi (:ebx (:ecx 2) -6)) - (:movl :edi (:ebx (:ecx 2) -2)) + (:movl :edi (:eax (:ecx 2) -6)) + (:movl :edi (:eax (:ecx 2) -2)) (:addl 4 :ecx) - (:cmpl :eax :ecx) - (:jb 'init-loop) - (:movl #.(movitz:tag :infant-object) (:ebx -2)))) + (:cmpl :ebx :ecx) + (:jb 'init-loop))) + +(defun los0-malloc-data-clumps (clumps) + (check-type clumps (integer 0 4000)) + (with-inline-assembly (:returns :eax) + retry + (:compile-form (:result-mode :ebx) clumps) + (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) + (:movl (:edx 2) :ecx) + (:leal ((:ebx 2) :ecx) :eax) + (:cmpl #x3fff4 :eax) + (:jge '(:sub-program () + (:compile-form (:result-mode :ignore) + (stop-and-copy)) + (:jmp 'retry))) + (:movl :eax (:edx 2)) + (:movl #.(movitz:tag :infant-object) (:edx :ecx 6)) + (:leal (:edx :ecx 8) :eax)))

(defun los0-handle-out-of-memory (exception interrupt-frame) (declare (ignore exception interrupt-frame)) @@ -104,20 +121,25 @@ (defun install-los0-consing () (setf (%run-time-context-slot 'nursery-space) (allocate-duo-space)) - (let ((conser (symbol-value 'new-fast-cons))) + (setf (exception-handler 113) + (lambda (exception interrupt-frame) + (declare (ignore exception interrupt-frame)) + (format t "~&;; Handling out-of-memory exception..") + (stop-and-copy))) + (let ((conser (symbol-value 'los0-fast-cons))) (check-type conser vector) (setf (%run-time-context-slot 'muerte::fast-cons) conser)) (let ((old-malloc (symbol-function 'muerte:malloc-clumps))) (setf (symbol-function 'muerte:malloc-clumps) - (symbol-function 'new-malloc-clumps)) - (setf (symbol-function 'new-malloc-clumps) + (symbol-function 'los0-malloc-clumps)) + (setf (symbol-function 'los0-malloc-clumps) old-malloc)) - (setf (exception-handler 113) - (lambda (exception interrupt-frame) - (declare (ignore exception interrupt-frame)) - (format t "~&;; Handling out-of-memory exception..") - (stop-and-copy))) + (let ((old-malloc-data (symbol-function 'muerte:malloc-data-clumps))) + (setf (symbol-function 'muerte:malloc-data-clumps) + (symbol-function 'los0-malloc-data-clumps)) + (setf (symbol-function 'los0-malloc-data-clumps) + old-malloc-data)) (values))

(defun install-old-consing () @@ -127,9 +149,14 @@ conser)) (let ((old-malloc (symbol-function 'muerte:malloc-clumps))) (setf (symbol-function 'muerte:malloc-clumps) - (symbol-function 'new-malloc-clumps)) - (setf (symbol-function 'new-malloc-clumps) + (symbol-function 'los0-malloc-clumps)) + (setf (symbol-function 'los0-malloc-clumps) old-malloc)) + (let ((old-malloc-data (symbol-function 'muerte:malloc-data-clumps))) + (setf (symbol-function 'muerte:malloc-data-clumps) + (symbol-function 'los0-malloc-data-clumps)) + (setf (symbol-function 'los0-malloc-data-clumps) + old-malloc-data)) (values))

(defun object-in-space-p (space object)