[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Wed Jul 7 23:39:51 UTC 2004
Update of /project/movitz/cvsroot/movitz/losp
In directory common-lisp.net:/tmp/cvs-serv12992
Modified Files:
los0-gc.lisp
Log Message:
Updated los0-gc to be compatible with the new basic-vectors, and to
allow spaces of any size. This means there's no longer any hard 256 KB
heap limit, even if this GC scheme is still rather simple. I've set
the default newspace size to 2 MB. You can easily override this with
the argument to install-los0-consing during bootup.
Date: Wed Jul 7 16:39:50 2004
Author: ffjeld
Index: movitz/losp/los0-gc.lisp
diff -u movitz/losp/los0-gc.lisp:1.18 movitz/losp/los0-gc.lisp:1.19
--- movitz/losp/los0-gc.lisp:1.18 Wed Jun 16 00:40:38 2004
+++ movitz/losp/los0-gc.lisp Wed Jul 7 16:39:50 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.18 2004/06/16 07:40:38 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.19 2004/07/07 23:39:50 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -18,82 +18,64 @@
(in-package muerte.init)
+(defconstant +space-size+ #xfffd)
+
(defun make-space (location)
"Make a space vector at a fixed location."
(assert (evenp location))
(macrolet ((x (index)
- `(memref location 0 ,index :unsigned-byte16)))
- (setf (x 0) #x0
- (x 1) #xfffd
- (x 2) #.(cl:dpb (bt:enum-value 'movitz:movitz-vector-element-type :u32)
+ `(memref location 0 ,index :unsigned-byte32)))
+ (setf (x 1) (* #.movitz:+movitz-fixnum-factor+ +space-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 :vector))
- (x 3) #xfffd))
+ (bt:enum-value 'movitz:other-type-byte :basic-vector))))
(%word-offset location #.(movitz:tag :other)))
-(defmacro space-other (space)
- `(memref ,space -6 3 :lisp))
(defmacro space-fresh-pointer (space)
`(memref ,space -6 2 :lisp))
-(defun allocate-space (&optional other-space)
- (let ((space (make-array #xfffd :element-type '(unsigned-byte 32))))
- (setf (space-fresh-pointer space) 2
- (space-other space) other-space)
+;;;(defmacro space-last-cons (space)
+;;; "The location of the last cons-cell that will with in this space."
+;;; `(memref ,space -6 3 :lisp))
+
+(defmacro space-other (space)
+ `(memref ,space -6 3 :lisp))
+
+(defun allocate-space (size &optional other-space)
+ (let ((space (make-array size :element-type '(unsigned-byte 32))))
+ (initialize-space space)
+ (setf (space-other space) other-space)
space))
(defun initialize-space (space)
- (setf (space-fresh-pointer space) 2))
-
-(defun allocate-duo-space ()
- (let* ((space1 (allocate-space))
- (space2 (allocate-space space1)))
- (setf (space-other space1) space2)))
+ (setf (space-fresh-pointer space) 2
+;;; (space-last-cons space) (+ (object-location space)
+;;; (array-dimension space 0)))
+ )
+ space)
+
+
+(defun allocate-duo-space (size)
+ (let* ((space1 (allocate-space size))
+ (space2 (allocate-space size space1)))
+ (setf (space-other space1) space2)
+ space1))
(defun space-cons-pointer ()
(aref (%run-time-context-slot 'nursery-space) 0))
-(define-primitive-function muerte::get-cons-pointer ()
- "Return in EAX the next object location with space for EAX words, with tag 6.
-Preserve ECX."
- (with-inline-assembly (:returns :multiple-values)
- retry
- (:locally (:cmpl 0 (:edi (:edi-offset atomically-status)))) ; Atomically?
- (:je '(:sub-program ()
- (:int 50))) ; This must be called inside atomically.
- (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
- (:movl (:edx 2) :ebx)
- (:leal (:ebx :eax 4) :eax)
- (:andl -8 :eax)
- (:cmpl #x3fff4 :eax)
- (:jae '(:sub-program (probe-failed)
- (:int 113)
- (:jmp 'retry)))
- (:movl :edi (:edx :ebx 8 #.movitz:+other-type-offset+))
- (:leal (:edx :ebx 8) :eax)
- (:ret)))
+(defun test ()
+ (warn "install..")
+ (install-los0-consing 4)
+ (warn "nursery: ~Z, other: ~Z"
+ (%run-time-context-slot 'muerte::nursery-space)
+ (space-other (%run-time-context-slot 'muerte::nursery-space)))
+ (warn "first cons: ~Z" (funcall 'truncate #x100000000 3))
+ (warn "second cons: ~Z" (funcall 'truncate #x100000000 3))
+ (halt-cpu)
+ (values))
-(define-primitive-function muerte::cons-commit ()
- "Commit allocation of ECX/fixnum words.
-Preserve EAX and EBX."
- (with-inline-assembly (:returns :multiple-values)
- retry
- (:locally (:cmpl 0 (:edi (:edi-offset atomically-status)))) ; Atomically?
- (:je '(:sub-program ()
- (:int 50))) ; This must be called inside atomically.
- (:addl #.movitz:+movitz-fixnum-factor+ :ecx)
- (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
- (:andl -8 :ecx)
- (:addl (:edx 2) :ecx)
- (:cmpl #x3fff4 :ecx)
- (:ja '(:sub-program (commit-failed)
- (:int 113)
- (:jmp 'retry)))
- (:movl :ecx (:edx 2))
- (:leal (:edx :ecx) :ecx)
- (:ret)))
-
(define-primitive-function los0-fast-cons ()
"Allocate a cons cell from nursery-space."
(macrolet
@@ -105,8 +87,9 @@
(:edi (:edi-offset atomically-status))))
(:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
(:movl (:edx 2) :ecx)
- (:cmpl #x3fff4 :ecx)
- (:ja '(:sub-program (allocation-failed)
+ (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+ :ecx)
+ (:jae '(:sub-program (allocation-failed)
;; Exit thread-atomical
(:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
(:edi (:edi-offset atomically-status))))
@@ -124,7 +107,54 @@
(:ret))))
(do-it)))
+(define-primitive-function muerte::get-cons-pointer ()
+ "Return in EAX the next object location with space for EAX words, with tag 6.
+Preserve ECX."
+ (macrolet
+ ((do-it ()
+ `(with-inline-assembly (:returns :multiple-values)
+ retry
+ (:locally (:cmpl 0 (:edi (:edi-offset atomically-status)))) ; Atomically?
+ (:je '(:sub-program ()
+ (:int 50))) ; This must be called inside atomically.
+ (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
+ (:movl (:edx 2) :ebx)
+ (:leal (:ebx :eax 4) :eax)
+ (:andl -8 :eax)
+ (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+ :eax)
+ (:ja '(:sub-program (probe-failed)
+ (:int 113)
+ (:jmp 'retry)))
+ (:movl :edi (:edx :ebx 8 ,movitz:+other-type-offset+))
+ (:leal (:edx :ebx 8) :eax)
+ (:ret))))
+ (do-it)))
+(define-primitive-function muerte::cons-commit ()
+ "Commit allocation of ECX/fixnum words.
+Preserve EAX and EBX."
+ (macrolet
+ ((do-it ()
+ `(with-inline-assembly (:returns :multiple-values)
+ retry
+ (:locally (:cmpl 0 (:edi (:edi-offset atomically-status)))) ; Atomically?
+ (:je '(:sub-program ()
+ (:int 50))) ; This must be called inside atomically.
+ (:addl ,movitz:+movitz-fixnum-factor+ :ecx)
+ (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
+ (:andl -8 :ecx)
+ (:addl (:edx 2) :ecx)
+ (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+ :ecx)
+ (:ja '(:sub-program (commit-failed)
+ (:int 113)
+ (:jmp 'retry)))
+ (:movl :ecx (:edx 2))
+ (:leal (:edx :ecx) :ecx)
+ (:ret))))
+ (do-it)))
+
(define-primitive-function los0-box-u32-ecx ()
"Make u32 in ECX into a fixnum or bignum."
(macrolet
@@ -140,8 +170,9 @@
(:edi (:edi-offset atomically-status))))
(:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
(:movl (:edx 2) :eax)
- (:cmpl #x3fff4 :eax)
- (:jge '(:sub-program ()
+ (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+ :eax)
+ (:jae '(:sub-program ()
(:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
(:edi (:edi-offset atomically-status))))
(:int 113) ; This interrupt can be retried.
@@ -159,7 +190,7 @@
(do-it)))
(defun los0-malloc-clumps (clumps)
- (check-type clumps (integer 0 16000))
+ (check-type clumps (integer 0 160000))
(macrolet
((do-it ()
`(with-inline-assembly (:returns :eax)
@@ -172,13 +203,14 @@
(:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
(:movl (:edx 2) :ecx)
(:leal ((:ebx 2) :ecx) :eax)
- (:cmpl #x3fff4 :eax)
- (:jge '(:sub-program ()
- (:int 113)))
+ (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+ :eax)
+ (:ja '(:sub-program ()
+ (:int 113)))
(:movl :eax (:edx 2))
(:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
(:edi (:edi-offset atomically-status))))
- (:movl #.(movitz:tag :infant-object) (:edx :ecx 6))
+ (:movl ,(movitz:tag :infant-object) (:edx :ecx 6))
(:leal (:edx :ecx 8) :eax)
(:xorl :ecx :ecx)
init-loop ; Now init eax number of clumps.
@@ -190,7 +222,7 @@
(do-it)))
(defun los0-malloc-data-clumps (clumps)
- (check-type clumps (integer 0 4000))
+ (check-type clumps (integer 0 160000))
(macrolet
((do-it ()
`(with-inline-assembly (:returns :eax)
@@ -203,9 +235,10 @@
(:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
(:movl (:edx 2) :ecx)
(:leal ((:ebx 2) :ecx) :eax)
- (:cmpl #x3fff4 :eax)
- (:jge '(:sub-program ()
- (:int 113)))
+ (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+ :eax)
+ (:ja '(:sub-program ()
+ (:int 113)))
(:movl :eax (:edx 2))
(:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
(:edi (:edi-offset atomically-status))))
@@ -214,33 +247,34 @@
(:leal (:edx :ecx 8) :eax))))
(do-it)))
-(defun install-los0-consing ()
- (setf (%run-time-context-slot 'nursery-space)
- (allocate-duo-space))
- (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 ((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 (&optional (space-kilobytes 2048))
+ (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))
+ (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 ((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-old-consing ()
(let ((conser (symbol-value 'muerte::fast-cons)))
@@ -333,7 +367,7 @@
forward-x))))))))
;; Scavenge roots
(map-heap-words evacuator 0 (+ (malloc-buffer-start)
- (* 2 (malloc-cons-pointer))))
+ (* 2 (malloc-cons-pointer))))
(map-stack-words evacuator (current-stack-frame))
;; Scan newspace, Cheney style.
(loop with newspace-location = (+ 2 (object-location newspace))
More information about the Movitz-cvs
mailing list