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

Modified Files:
	los0-gc.lisp 
Log Message:
Added a handler for the out-of-memory exception to automatically call
stop-and-copy. So now the GC architecture should in principle be complete!

Date: Tue Apr  6 20:45:54 2004
Author: ffjeld

Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.4 movitz/losp/los0-gc.lisp:1.5
--- movitz/losp/los0-gc.lisp:1.4	Tue Apr  6 19:47:26 2004
+++ movitz/losp/los0-gc.lisp	Tue Apr  6 20:45:54 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.4 2004/04/06 23:47:26 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.5 2004/04/07 00:45:54 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -57,10 +57,13 @@
 (define-primitive-function new-fast-cons ()
   "Allocate a cons cell from nursery-space."
   (with-inline-assembly (:returns :eax)
+   retry-cons
     (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
     (:movl (:edx 2) :ecx)
     (:cmpl #x3fff4 :ecx)
-    (:jge '(:sub-program () (:int 112)))
+    (:jge '(:sub-program ()
+	    (:int 112)
+	    (:jmp 'retry-cons)))
     (:movl :eax (:edx :ecx 2))
     (:movl :ebx (:edx :ecx 6))
     (:leal (:edx :ecx 3) :eax)
@@ -92,6 +95,11 @@
     (:jb 'init-loop)
     (:movl #.(movitz:tag :infant-object) (:ebx -2))))
 
+(defun los0-handle-out-of-memory (exception interrupt-frame)
+  (declare (ignore exception interrupt-frame))
+  (format t "~&;; Handling out-of-memory exception..")
+  (stop-and-copy))
+
 (defun install-los0-consing ()
   (setf (%run-time-context-slot 'nursery-space)
     (allocate-duo-space))
@@ -104,6 +112,7 @@
       (symbol-function 'new-malloc-clumps))
     (setf (symbol-function 'new-malloc-clumps)
       old-malloc))
+  (setf (interrupt-handler 112) 'los0-handle-out-of-memory)
   (values))
 
 (defun install-old-consing ()