[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp

[Frode Vatvedt Fjeld]

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 at 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)