Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv7579/losp

Modified Files: los0-gc.lisp los0.lisp Log Message: many cleanup regarding stack and register discipline. Date: Wed Sep 15 12:22:58 2004 Author: ffjeld

Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.35 movitz/losp/los0-gc.lisp:1.36 --- movitz/losp/los0-gc.lisp:1.35 Thu Sep 2 11:33:06 2004 +++ movitz/losp/los0-gc.lisp Wed Sep 15 12:22:57 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.35 2004/09/02 09:33:06 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.36 2004/09/15 10:22:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -146,7 +146,7 @@ retry (:locally (:cmpl 0 (:edi (:edi-offset atomically-status)))) ; Atomically? (:je '(:sub-program () - (:int 50))) ; This must be called inside atomically. + (:int 63))) ; This must be called inside atomically. (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) (:movl (:edx 2) :ebx) (:leal (:ebx :eax 4) :eax) @@ -205,6 +205,8 @@ (:jae '(:sub-program () (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) (:edi (:edi-offset atomically-status)))) + (:movl :edx (#x1000000)) + (:addl :eax (#x1000000)) (:int 113) ; This interrupt can be retried. (:jmp 'retry-cons))) (:movl ,(dpb movitz:+movitz-fixnum-factor+ @@ -239,9 +241,13 @@ (:movl :ebx :eax) ; Restore count in EAX before retry (:jmp 'retry))) (:movl :eax (:edx 2)) - (:movl ,(movitz:tag :infant-object) (:edx :ecx ,(+ 8 movitz:+other-type-offset+))) + (:movl ,(movitz:basic-vector-type-tag :any-t) + (:edx :ecx ,(+ 8 movitz:+other-type-offset+))) + (:subl 8 :ebx) + (:movl :ebx (:edx :ecx ,(+ 16 movitz:+other-type-offset+))) (:leal (:edx :ecx 8) :eax) (:xorl :ecx :ecx) + (:addl 8 :ecx) init-loop ; Now init ebx number of words (:movl :edi (:eax :ecx ,(- (movitz:tag :other)))) (:addl 4 :ecx) @@ -285,22 +291,22 @@ (setf (exception-handler 113) (lambda (exception interrupt-frame) (declare (ignore exception interrupt-frame)) - (let ((*standard-output* *terminal-io*)) - (when *gc-running* - (let ((muerte::*error-no-condition-for-debugger* t)) - (warn "Recursive GC triggered."))) - (let ((*gc-running* t)) - (unless *gc-quiet* - (format t "~&;; GC.. ")) - (stop-and-copy)) - (if *gc-break* - (break "GC break.") - (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)))))))) + (without-interrupts + (let ((*standard-output* *terminal-io*)) + (when *gc-running* + (break "Recursive GC triggered.")) + (let ((*gc-running* t)) + (unless *gc-quiet* + (format t "~&;; GC.. ")) + (stop-and-copy)) + (if *gc-break* + (break "GC break.") + (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))))))))) (let* ((actual-duo-space (or duo-space (allocate-duo-space (* kb-size #x100)))) (last-location (object-location (cons 1 2)))) @@ -315,8 +321,8 @@ (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) - (install-primitive los0-malloc-pointer-words muerte::malloc-pointer-words) - (install-primitive los0-malloc-non-pointer-words muerte::malloc-non-pointer-words)) + #+ignore (install-primitive los0-malloc-pointer-words muerte::malloc-pointer-words) + #+ignore (install-primitive los0-malloc-non-pointer-words muerte::malloc-non-pointer-words)) (if (eq context (current-run-time-context)) (setf (%run-time-context-slot 'muerte::nursery-space) actual-duo-space) @@ -384,6 +390,10 @@ (check-type space0 vector-u32) (check-type space1 vector-u32) (assert (eq space0 (space-other space1))) + (assert (= 2 (space-fresh-pointer space1))) + (setf (%run-time-context-slot 'nursery-space) space1) + (values space1 space0) + #+ignore (multiple-value-bind (newspace oldspace) (if (< (space-fresh-pointer space0) ; Chose the emptiest space as newspace. (space-fresh-pointer space1)) @@ -403,23 +413,22 @@ nil) ((not (object-in-space-p oldspace x)) x) - (t - (or (and (eq (object-tag x) - (ldb (byte 3 0) - (memref (object-location x) 0 0 :unsigned-byte8))) - (let ((forwarded-x (memref (object-location x) 0 0 :lisp))) - (and (object-in-space-p newspace forwarded-x) - forwarded-x))) - (let ((forward-x (shallow-copy x))) - (when (and (typep x 'muerte::pointer) - *gc-consitency-check*) - (let ((a *x*)) - (vector-push (%object-lispval x) a) - (vector-push (memref (object-location x) 0 0 :unsigned-byte32) a) - (assert (vector-push (%object-lispval forward-x) a)))) - (setf (memref (object-location x) 0 0 :lisp) forward-x) - forward-x)))))))) - (setf *gc-stack* (muerte::copy-control-stack)) + (t (or (and (eq (object-tag x) + (ldb (byte 3 0) + (memref (object-location x) 0 0 :unsigned-byte8))) + (let ((forwarded-x (memref (object-location x) 0 0 :lisp))) + (and (object-in-space-p newspace forwarded-x) + forwarded-x))) + (let ((forward-x (shallow-copy x))) + (when (and (typep x 'muerte::pointer) + *gc-consitency-check*) + (let ((a *x*)) + (vector-push (%object-lispval x) a) + (vector-push (memref (object-location x) 0 0 :unsigned-byte32) a) + (assert (vector-push (%object-lispval forward-x) a)))) + (setf (memref (object-location x) 0 0 :lisp) forward-x) + forward-x)))))))) + (setf *gc-stack* (muerte::copy-current-control-stack)) ;; Scavenge roots (dolist (range muerte::%memory-map-roots%) (map-heap-words evacuator (car range) (cdr range))) @@ -470,5 +479,36 @@ ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%" old-size new-size (- old-size new-size)))) (initialize-space oldspace) - #+ignore (fill oldspace #x13 :start 2))) + (fill oldspace #x13 :start 2))) (values)) + + +(defun find-object-by-location (location &key (continuep t) (breakp nil)) + "Scan the heap for a (pointer) object that matches location. +This is a debugging tool." + (let ((results nil)) + (flet ((searcher (x ignore) + (declare (ignore ignore)) + (when (and (typep x '(or muerte::tag1 muerte::tag6 muerte::tag7)) + (not (eq x (%run-time-context-slot 'muerte::nursery-space))) + (location-in-object-p x location) + (not (member x results))) + (push x results) + (funcall (if breakp #'break #'warn) + "Found pointer ~Z of type ~S at location ~S." + x (type-of x) (object-location x))) + x)) + (handler-bind + ((serious-condition (lambda (c) + (when (and continuep + (find-restart 'muerte::continue-map-heap-words)) + (warn "Automatic continue from scanning error: ~A" c) + (invoke-restart 'muerte::continue-map-heap-words))))) + (dolist (range muerte::%memory-map-roots%) + (map-heap-words #'searcher (car range) (cdr range))) + (let ((nursery (%run-time-context-slot 'muerte::nursery-space))) + (map-heap-words #'searcher + (+ 4 (object-location nursery)) + (+ 4 (object-location nursery) (space-fresh-pointer nursery)))) + (map-stack-words #'searcher nil (current-stack-frame)))) + results))

Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.20 movitz/losp/los0.lisp:1.21 --- movitz/losp/los0.lisp:1.20 Wed Jul 28 16:15:17 2004 +++ movitz/losp/los0.lisp Wed Sep 15 12:22:57 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.20 2004/07/28 14:15:17 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.21 2004/09/15 10:22:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -46,8 +46,6 @@

(in-package muerte.init)

-(declaim (special muerte::*multiboot-data*)) - (defun test-floppy () (muerte.x86-pc::fd-start-disk) ; to initialize the controller and spin the drive up. (muerte.x86-pc::fd-cmd-seek 70) ; to seek to track 70. @@ -101,10 +99,12 @@ ;;; (values-list x) ;;; (warn "sym: ~S, stat: ~S" symbol status))) ;;; -;;;(defun test-loop (x) -;;; (format t "test-loop: ~S~%" -;;; (loop for i from 0 to 10 collect x))) -;;; + +#+ignore +(defun test-loop (x) + (format t "test-loop: ~S~%" + (loop for i from 0 to 10 collect x))) + #+ignore (defun delay (time) (dotimes (i time) @@ -133,6 +133,23 @@ (print x) 'jumbo)

+(defun jumbo2 (a b &rest x) + (declare (dynamic-extent x)) + (print a) (print b) + (print x) + 'jumbo) + +(defun jumbo3 (a &rest x) + (declare (dynamic-extent x)) + (print a) + (print x) + 'jumbo) + +(defun jumbo4 (&rest x) + (declare (dynamic-extent x)) + (print x) + 'jumbo) + #+ignore (defun kumbo (&key a b (c (jumbo 1 2 3)) d) (print a) @@ -145,15 +162,34 @@ (print a) (print b))

+(defmacro do-check-esp (&body body) + `(let ((before (with-inline-assembly (:returns :eax) (:movl :esp :eax)))) + (with-inline-assembly (:returns :nothing) + (:compile-form (:result-mode :multiple-values) (progn ,@body))) + (unless (eq before + (with-inline-assembly (:returns :eax) (:movl :esp :eax))) + (error "ESP before body: ~S, after: ~S" + (with-inline-assembly (:returns :eax) (:movl :esp :eax)))))) + #+ignore (defun test-m-v-call () + (do-check-esp + (multiple-value-call #'format t "~@{ ~D~}~%" + 'a (values) 'b (test-loop 1) (make-values) + 'c 'd 'e (make-no-values) 'f))) + +(defun test-m-v-call2 () (multiple-value-call #'format t "~@{ ~D~}~%" - 'a (values) 'b (test-loop 1) (make-values) - 'c 'd 'e (make-no-values) 'f)) + 'a 'b (values 1 2 3) 'c 'd 'e 'f))

(defun make-values () (values 0 1 2 3 4 5))

+(defun xfuncall (&rest args) + (declare (dynamic-extent args)) + (break "xfuncall:~{ ~S~^,~}" args) + (values)) + (defun xx () (format t "wefewf") (with-inline-assembly (:returns :untagged-fixnum-ecx) @@ -162,10 +198,11 @@ (:leal (:edx :ecx 1) :ecx)))

(defun xfoo (f) - (multiple-value-bind (a b c d) - (multiple-value-prog1 (make-values) - (format t "hello world")) - (format t "~&a: ~S, b: ~S, c: ~S, d: ~S" a b c d f))) + (do-check-esp + (multiple-value-bind (a b c d) + (multiple-value-prog1 (make-values) + (format t "hello world")) + (format t "~&a: ~S, b: ~S, c: ~S, d: ~S ~S" a b c d f))))

#+ignore @@ -215,6 +252,17 @@ (pingo 5)))

#+ignore +(defun foo-type (length start1 sequence-1) + (do* ((i 0 #+ignore (+ start1 length -1) (1- i))) + ((< i start1) sequence-1) + (declare (type muerte::index i length)) + (setf (sequence-1-ref i) + 'foo))) + +(defun plus (a b) + (+ b a)) + +#+ignore (defun test-values () (multiple-value-bind (a b c d e f g h i j) (multiple-value-prog1 @@ -573,6 +621,11 @@ (let ((x (car p))) (print x))))

+(defun mubmo () + (let ((x (muerte::copy-funobj #'format)) + (y (cons 1 2))) + (warn "x: ~Z, y: ~Z" x y))) + ;;;;;

(defclass food () ()) @@ -696,10 +749,6 @@

;;;;;

-(defvar div #xa65feaab511c61e33df38fdddaf03b59b6f25e1fa4de57e5cf00ae478a855dda4f3638d38bb00ac4af7d8414c3fb36e04fbdf3d3166712d43b421bfa757e85694ad27c48f396d03c8bce8da58db5b82039f35dcf857235c2f1c73b2226a361429190dcb5b6cd0edfb0ff6933900b02cecc0ce69274d8dae7c694804318d6d6b9) - -(defvar guess #x1dc19f99401de22d476c89943491fc187b80bcfa8293ec1cf69c1a81352f047e894e262d24116c82ad0be241c6c6216cab9b66d64417d43bf433db10114c0) - ;;;;;;;;;;;;;;; CL

(defun install-internal-time (&optional (minimum-frequency 100)) @@ -956,23 +1005,24 @@ (return (values)))))))

(defun los0-debugger (condition) - (let ((*debugger-dynamic-context* (current-dynamic-context)) - (*standard-output* *debug-io*) - (*standard-input* *debug-io*) - (*debugger-condition* condition) - (*package* (or (and (packagep *package*) *package*) - (find-package "INIT") - (find-package "USER") - (find-package "COMMON-LISP") - (error "Unable to find any package!"))) - (*repl-prompt-context* #\d) - (*repl-readline-context* (or *repl-readline-context* - (make-readline-context :history-size 16)))) - (let ((*print-safely* t)) - (invoke-toplevel-command :error)) - (loop - (with-simple-restart (abort "Abort to command level ~D." (1+ *repl-level*)) - (read-eval-print))))) + (without-interrupts + (let ((*debugger-dynamic-context* (current-dynamic-context)) + (*standard-output* *debug-io*) + (*standard-input* *debug-io*) + (*debugger-condition* condition) + (*package* (or (and (packagep *package*) *package*) + (find-package "INIT") + (find-package "USER") + (find-package "COMMON-LISP") + (error "Unable to find any package!"))) + (*repl-prompt-context* #\d) + (*repl-readline-context* (or *repl-readline-context* + (make-readline-context :history-size 16)))) + (let ((*print-safely* t)) + (invoke-toplevel-command :error)) + (loop + (with-simple-restart (abort "Abort to command level ~D." (1+ *repl-level*)) + (read-eval-print))))))

(defun ub (x) `(hello world ,x or . what)) @@ -1020,6 +1070,109 @@ (:stc)) (values eax ebx ecx edx p1 p2)))

+(defun my-test-labels (x) + (labels (#+ignore (p () (print x)) + (q (y) (list x y))) + (declare (ignore q)) + (1+ x))) + +(defparameter *timer-stack* nil) +(defparameter *timer-esi* nil) +(defparameter *timer-frame* #100()) + +(defun test-clc (&optional timeout) + (test-timer timeout) + (loop + (clc::test-clc))) + +(defun test-timer (&optional timeout) + (setf (exception-handler 32) + (lambda (exception-vector exception-frame) + (declare (ignore exception-vector #+ignore exception-frame)) +;;; (loop with f = *timer-frame* +;;; for o from 20 downto -36 by 4 as i upfrom 0 +;;; do (setf (aref f i) (memref exception-frame o 0 :lisp))) +;;; (let ((ts *timer-stack*)) +;;; (setf (fill-pointer ts) 0) +;;; (loop for stack-frame = exception-frame then (stack-frame-uplink stack-frame) +;;; while (plusp stack-frame) +;;; do (multiple-value-bind (offset code-vector funobj) +;;; (stack-frame-call-site stack-frame) +;;; (vector-push funobj ts) +;;; (vector-push offset ts) +;;; (vector-push code-vector ts)))) + (muerte::cli) + (pic8259-end-of-interrupt 0) + (with-inline-assembly (:returns :nothing) + (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*) + (:shrl 2 :ecx) + ((:gs-override) :addb 1 (:ecx 158)) + ((:gs-override) :movb #x40 (:ecx 159))) + (setf *timer-esi* (muerte::dit-frame-ref nil exception-frame :esi :unsigned-byte32)) + (do ((frame (stack-frame-uplink nil (current-stack-frame)) + (stack-frame-uplink nil frame))) + ((plusp frame)) + (when (eq (with-inline-assembly (:returns :eax) (:movl :esi :eax)) + (stack-frame-funobj nil frame)) + (error "Double interrupt."))) + #+ignore + (dolist (range muerte::%memory-map-roots%) + (map-heap-words (lambda (x type) + (declare (ignore type)) + x) + (car range) (cdr range))) + (map-stack-words (lambda (x foo) + (declare (ignore foo)) + x) + nil + (current-stack-frame)) + (setf *timer-stack* (muerte::copy-current-control-stack)) + (setf (pit8253-timer-mode 0) +pit8253-mode-single-timeout+ + (pit8253-timer-count 0) (or timeout (+ 10 (random 4000)))) + (with-inline-assembly (:returns :nothing) + (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*) + (:shrl 2 :ecx) + ((:gs-override) :movb #x20 (:ecx 159))) + (muerte::sti) + )) + (with-inline-assembly (:returns :nothing) + (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*) + (:shrl 2 :ecx) + ((:gs-override) :movw #x4646 (:ecx 158))) + (setf (pit8253-timer-mode 0) +pit8253-mode-single-timeout+ + (pit8253-timer-count 0) (or timeout (+ 10 (random 4000)))) + (setf (pic8259-irq-mask) #xfffe) + (pic8259-end-of-interrupt 0) + (with-inline-assembly (:returns :nothing) (:sti)) + ;; (dotimes (i 100000)) + #+ignore + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ebx :edx) + (read-time-stamp-counter) + (read-time-stamp-counter)) + (:movl :eax (#x1000000)) + (:movl :ebx (#x1000004)) + (:movl :ecx (#x1000008)) + (:movl :edx (#x100000c)) + (:movl :ebp (#x1000010)) + (:movl :esp (#x1000014)) + (:movl :esi (#x1000018)) + (:halt) + (:cli) + (:halt) + )) + +(defun test-throwing (&optional (x #xffff)) + (test-timer x) + (loop + (catch 'foo + (funcall (lambda () + (unless (logbitp 9 (eflags)) + (break "Someone switched off interrupts!")) + (incf (memref-int muerte.x86-pc::*screen* 0 0 :unsigned-byte16 t)) + (throw 'foo nil)))))) + + (defun genesis () (let ((extended-memsize 0)) ;; Find out how much extended memory we have @@ -1030,10 +1183,10 @@ (format t "Extended memory: ~D KB~%" extended-memsize)

(idt-init) - (install-los0-consing :kb-size 50) + (install-los0-consing :kb-size 500) #+ignore (install-los0-consing :kb-size (max 100 (truncate (- extended-memsize 1024 2048) 2)))) - + (setf *debugger-function* #'los0-debugger) (let ((*repl-readline-context* (make-readline-context :history-size 16)) #+ignore (*backtrace-stack-frame-barrier* (stack-frame-uplink (current-stack-frame))) @@ -1049,6 +1202,9 @@

(setf *package* (find-package "INIT")) (clos-bootstrap) + (when muerte::*multiboot-data* + (set-textmode +vga-state-90x60+)) + (cond ((not (cpu-featurep :tsc)) (warn "This CPU has no time-stamp-counter. Timer-related functions will not work.")) @@ -1065,7 +1221,7 @@ (let ((* nil) (** nil) (*** nil) (/ nil) (// nil) (/// nil) (+ nil) (++ nil) (+++ nil)) - (format t "~&Movitz image Los0 build ~D." *build-number*) + (format t "~&Movitz image Los0 build ~D [~Z]." *build-number* (cons 1 2)) (loop (catch :top-level-repl ; If restarts don't work, you can throw this.. (with-simple-restart (abort "Abort to the top command level.")