[movitz-cvs] CVS movitz/losp
ffjeld
ffjeld at common-lisp.net
Mon Apr 9 17:30:13 UTC 2007
Update of /project/movitz/cvsroot/movitz/losp
In directory clnet:/tmp/cvs-serv4744
Modified Files:
los0-gc.lisp
Log Message:
Renamed the 'muerte.init' package to 'los0'. Refactored the los0.lisp
file such that most of the cruft is moved into scratch.lisp, the
shallow-binding stuff is moved into lib/shallow-binding.lisp, and what
remains in los0.lisp is just the core mechanisms for the los0 kernel
application.
--- /project/movitz/cvsroot/movitz/losp/los0-gc.lisp 2006/10/27 06:23:32 1.61
+++ /project/movitz/cvsroot/movitz/losp/los0-gc.lisp 2007/04/09 17:30:09 1.62
@@ -10,13 +10,13 @@
;;;; Author: Frode Vatvedt Fjeld <frodef at acm.org>
;;;; Created at: Sat Feb 21 17:48:32 2004
;;;;
-;;;; $Id: los0-gc.lisp,v 1.61 2006/10/27 06:23:32 ffjeld Exp $
+;;;; $Id: los0-gc.lisp,v 1.62 2007/04/09 17:30:09 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
(provide :los0-gc)
-(in-package muerte.init)
+(in-package los0)
(defvar *gc-quiet* nil)
(defvar *gc-running* nil)
@@ -91,10 +91,22 @@
((do-it ()
`(with-inline-assembly (:returns :eax)
retry-cons
- ;; Set up thread-atomical execution
+
+;; (:locally (:cmpl #xabbabee0 (:edi (:edi-offset values) ,(* 4 #x30))))
+;; (:je 'no-check)
+;; (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
+;; (:movl (:edx 6) :edx); other
+;; (:cmpl 8 (:edx 2))
+;; (:jne '(:sub-program ()
+;; (:locally (:movl #xabbabee0 (:edi (:edi-offset values) ,(* 4 #x30))))
+;; (:break)))
+;; no-check
+
+ ;; Set up thread-atomical execution
(:locally (:movl ,(movitz::atomically-continuation-simple-pf 'fast-cons)
(:edi (:edi-offset atomically-continuation))))
- (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
+
+ (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
(:movl (:edx 2) :ecx)
(:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
:ecx)
@@ -230,6 +242,18 @@
(defvar *gc-stack* nil)
(defvar *gc-stack2* nil)
+(defmacro with-hack-space ((&key (size 409600)) &body body)
+ `(let* ((id (with-inline-assembly (:returns :eax) (:movl :esp :eax)))
+ (save-space (%run-time-context-slot nil 'muerte::nursery-space))
+ (hack-space (make-duo-space (duo-space-end-location save-space) ,size)))
+ (warn "[~A] hack-space ~Z from ~Z/~Z: ~A" id hack-space save-space (space-other save-space) ',body)
+ (unwind-protect
+ (progn
+ (setf (%run-time-context-slot nil 'muerte::nursery-space) hack-space)
+ , at body)
+ (warn "[~A] hack-space done." id)
+ (setf (%run-time-context-slot nil 'muerte::nursery-space) save-space))))
+
(defun install-los0-consing (&key (context (current-run-time-context))
(kb-size 1024)
duo-space)
@@ -240,26 +264,40 @@
(lambda (exception interrupt-frame)
(declare (ignore exception interrupt-frame))
(without-interrupts
- (let ((*standard-output* *terminal-io*))
- (cond
- (*gc-running*
- (let* ((full-space (%run-time-context-slot nil 'muerte::nursery-space))
- (hack-space (make-duo-space (duo-space-end-location full-space) 102400)))
- (setf (%run-time-context-slot nil 'muerte::nursery-space) hack-space)
- (break "Recursive GC triggered. Full-space: ~Z, hack-space: ~Z"
- full-space hack-space)))
- (t (let ((*gc-running* t))
- (unless *gc-quiet*
- (format t "~&;; GC.. "))
- (stop-and-copy))))
+ (let ((muerte::*active-condition-handlers* nil)
+ (*debugger-hook* nil)
+ (*standard-output* *terminal-io*))
+ (cond
+ (*gc-running*
+ (let* ((full-space (%run-time-context-slot nil 'muerte::nursery-space))
+ (hack-space (make-duo-space (duo-space-end-location full-space) 102400)))
+ (setf (%run-time-context-slot nil 'muerte::nursery-space) hack-space)
+ (break "Recursive GC triggered. Full-space: ~Z, hack-space: ~Z"
+ full-space hack-space)))
+ (t (let ((*gc-running* t))
+ (unless *gc-quiet*
+ (format t "~&;; GC ~Z.." (%run-time-context-slot nil 'muerte::nursery-space)))
+ (let* ((space0 (%run-time-context-slot nil 'nursery-space))
+ (space1 (space-other space0)))
+ (unless (= 2 (space-fresh-pointer space1))
+ (with-hack-space ()
+ (error "PRE space-other is not initialized: ~S" (space-fresh-pointer space1)))))
+ (unwind-protect
+ (stop-and-copy)
+ (let* ((space0 (%run-time-context-slot nil 'nursery-space))
+ (space1 (space-other space0)))
+ (unless (= 2 (space-fresh-pointer space1))
+ (with-hack-space ()
+ (error "UP space-other is not initialized: ~S" (space-fresh-pointer space1))))
+ )))))
(if *gc-break*
(break "GC break.")
- (loop ; This is a nice opportunity to poll the keyboard..
- (case (muerte.x86-pc.keyboard:poll-char)
- ((#\escape)
- (break "Los0 GC keyboard poll."))
- ((nil)
- (return)))))))))
+ (loop ; This is a nice opportunity to poll the keyboard..
+ (case (muerte.x86-pc.keyboard:poll-char)
+ ((#\escape)
+ (break "Los0 GC keyboard poll."))
+ ((nil)
+ (return)))))))))
(let* ((actual-duo-space (or duo-space
(allocate-duo-space (* kb-size #x100))))
(last-location (object-location (cons 1 2))))
@@ -332,9 +370,12 @@
(values))))
-(defparameter *x* #4000(nil)) ; Have this in static space.
+(defparameter *x* (make-array #x1000 :fill-pointer 0)) ; Have this in static space.
;;;(defparameter *xx* #4000(nil)) ; Have this in static space.
+(defvar *gc-x1* nil)
+(defvar *gc-x2* nil)
+
(defparameter *code-vector-foo* 0)
(defvar *old-code-vectors* #250(nil))
(defvar *new-code-vectors* #250(nil))
@@ -349,7 +390,10 @@
(check-type space0 (simple-array (unsigned-byte 32) 1))
(check-type space1 (simple-array (unsigned-byte 32) 1))
(assert (eq space0 (space-other space1)))
- (assert (= 2 (space-fresh-pointer space1)))
+ (unless (= 2 (space-fresh-pointer space1))
+ (with-hack-space ()
+ (error "space1 is not initialized: ~S" (space-fresh-pointer space1))
+ nil))
(setf (%run-time-context-slot nil 'nursery-space) space1)
(values space1 space0)))
;; Evacuate-oldspace is to be mapped over every potential pointer.
@@ -364,31 +408,29 @@
nil)
((object-in-space-p newspace x)
x)
- #+ignore
- ((and (typep x 'code-vector)
- (not (object-in-space-p oldspace x))
- (not (object-in-space-p newspace x))
- (= (ldb (byte 12 0) (object-location x))
- (ldb (byte 12 0) *code-vector-foo*))
- (not (eq x (funobj-code-vector #'stop-and-copy)))
- (not (eq x (symbol-value 'muerte::default-interrupt-trampoline)))
-;;; (not (eq x (symbol-value 'muerte::ret-trampoline)))
- (not (muerte::scavenge-find-pf (lambda (x y) x) (object-location x))))
- (let ((p (position (object-location x) *old-code-vectors*)))
- (if p
- (aref *new-code-vectors* p)
- (setf (aref *new-code-vectors*
- (vector-push (object-location x) *old-code-vectors*))
- (let ((new (shallow-copy x)))
- (warn "[~S] Migrating ~@[~S ~]~Z => ~Z."
- location
- (muerte::locate-function (object-location x))
- x new)
- new)))))
+ #+ignore ((and (typep x 'code-vector)
+ (not (object-in-space-p oldspace x))
+ (not (object-in-space-p newspace x))
+ (= (ldb (byte 12 0) (object-location x))
+ (ldb (byte 12 0) *code-vector-foo*))
+ (not (eq x (funobj-code-vector #'stop-and-copy)))
+ (not (eq x (symbol-value 'muerte::default-interrupt-trampoline)))
+ (not (muerte::scavenge-find-pf (lambda (x y) x) (object-location x))))
+ (let ((p (position (object-location x) *old-code-vectors*)))
+ (if p
+ (aref *new-code-vectors* p)
+ (setf (aref *new-code-vectors*
+ (vector-push (object-location x) *old-code-vectors*))
+ (let ((new (shallow-copy x)))
+ (warn "[~S] Migrating ~@[~S ~]~Z => ~Z."
+ location
+ (muerte::locate-function (object-location x))
+ x new)
+ new)))))
((not (object-in-space-p oldspace x))
x)
- ((when (typep x 'run-time-context)
- (warn "Scavenging ~S" x)))
+ #+ignore ((when (typep x 'run-time-context)
+ (warn "Scavenging ~S" x)))
(t (or (and (eq (object-tag x)
(ldb (byte 3 0)
(memref (object-location x) 0 :type :unsigned-byte8)))
@@ -415,10 +457,12 @@
with scan-pointer of-type index = 2
as fresh-pointer of-type index = (space-fresh-pointer newspace)
while (< scan-pointer fresh-pointer)
- do (map-header-vals evacuator
- (+ newspace-location scan-pointer)
- (+ newspace-location (space-fresh-pointer newspace)))
- (setf scan-pointer fresh-pointer))
+ do (let ((start (+ newspace-location scan-pointer))
+ (end (+ newspace-location (space-fresh-pointer newspace))))
+ (map-header-vals evacuator start end)
+ (setf *gc-x1* start)
+ (setf *gc-x2* end))
+ (setf scan-pointer fresh-pointer))
(when *gc-consistency-check*
;; Consistency check..
(map-stack-vector (lambda (x foo)
@@ -426,7 +470,7 @@
x)
nil
(current-stack-frame))
- (with-simple-restart (continue "Ignore failed GC consistency check.")
+ (with-simple-restart (continue "Skip GC consistency check.")
(without-interrupts
(let ((a *x*))
;; First, restore the state of old-space
More information about the Movitz-cvs
mailing list