[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-serv30689

Modified Files:
	los0-gc.lisp 
Log Message:
Some pieces of los0-gc were (because of laziness) set up as part of
the default system. This factors out los0-gc from the default system
properly. Also, changed the signature and implementation of
install-los0-consing a bit: It now takes the run-time-context object
to install onto as an explicit (keyword) argument.

Date: Thu Jul 15 04:22:08 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.26 movitz/losp/los0-gc.lisp:1.27
--- movitz/losp/los0-gc.lisp:1.26	Wed Jul 14 17:27:13 2004
+++ movitz/losp/los0-gc.lisp	Thu Jul 15 04:22:08 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.26 2004/07/15 00:27:13 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.27 2004/07/15 11:22:08 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -99,7 +99,7 @@
 	    (:ret))))
     (do-it)))
 
-(define-primitive-function muerte::get-cons-pointer ()
+(define-primitive-function los0-get-cons-pointer ()
   "Return in EAX the next object location with space for EAX words, with tag 6.
 Preserve ECX."
   (macrolet
@@ -123,7 +123,7 @@
 	    (:ret))))
     (do-it)))
 
-(define-primitive-function muerte::cons-commit ()
+(define-primitive-function los0-cons-commit ()
   "Commit allocation of ECX/fixnum words.
 Preserve EAX and EBX."
   (macrolet
@@ -240,42 +240,44 @@
 	    (:leal (:edx :ecx 8) :eax))))
     (do-it)))
 
-(defun install-los0-consing (&optional (space-kilobytes 1024))
-  (let ((size (* space-kilobytes #x100)))
-    (setf (%run-time-context-slot 'nursery-space)
-      (allocate-duo-space size))
-    (setf (exception-handler 113)
-      (lambda (exception interrupt-frame)
-	(declare (ignore exception interrupt-frame))
-	(unless *gc-quiet*
-	  (format t "~&;; GC.. "))
-	(stop-and-copy)
-	;; This is  a nice opportunity to poll the keyboard..
-	(loop
-	  (case (muerte.x86-pc.keyboard:poll-char)
-	    ((#\esc)
-	     (break "Los0 GC keyboard poll."))
-	    ((nil)
-	     (return))))))
-    (let ((conser (symbol-value 'los0-fast-cons)))
-      (check-type conser vector)
-      (setf (%run-time-context-slot 'muerte::fast-cons)
-	conser))
-    (let ((conser (symbol-value 'los0-box-u32-ecx)))
-      (check-type conser vector)
-      (setf (%run-time-context-slot 'muerte::box-u32-ecx)
-	conser))
-    (let ((old-malloc (symbol-function 'muerte:malloc-clumps)))
-      (setf (symbol-function 'muerte: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 install-los0-consing (&key (run-time-context (current-run-time-context))
+				  (kb-size 1024)
+				  duo-space)
+  "Install the 'Los0' GC architecture on run-time-context."
+  (setf (%run-time-context-slot 'nursery-space run-time-context)
+    (or duo-space
+	(allocate-duo-space (* kb-size #x100))))
+  (setf (exception-handler 113)
+    (lambda (exception interrupt-frame)
+      (declare (ignore exception interrupt-frame))
+      (unless *gc-quiet*
+	(format t "~&;; GC.. "))
+      (stop-and-copy)
+      (loop				; This is  a nice opportunity to poll the keyboard..
+	(case (muerte.x86-pc.keyboard:poll-char)
+	  ((#\esc)
+	   (break "Los0 GC keyboard poll."))
+	  ((nil)
+	   (return))))))
+  (flet ((install-primitive (name slot)
+	   (let ((code-vector (symbol-value name)))
+	     (check-type code-vector code-vector)
+	     (setf (%run-time-context-slot slot run-time-context) code-vector))))
+    (install-primitive 'los0-fast-cons 'muerte::fast-cons)
+    (install-primitive 'los0-box-u32-ecx 'muerte::box-u32-ecx)
+    (install-primitive 'los0-get-cons-pointer 'muerte::get-cons-pointer)
+    (install-primitive 'los0-cons-commit 'muerte::cons-commit))
+  (let ((old-malloc (symbol-function 'muerte:malloc-clumps)))
+    (setf (symbol-function 'muerte: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 install-old-consing ()
   (let ((conser (symbol-value 'muerte::fast-cons)))