March 2005 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS update: public_html/ChangeLog
by ffjeld＠common-lisp.net 09 Mar '05

09 Mar '05

Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv8806 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Mar 9 08:33:09 2005 Author: ffjeld Index: public_html/ChangeLog diff -u public_html/ChangeLog:1.2 public_html/ChangeLog:1.3 --- public_html/ChangeLog:1.2 Thu Feb 24 13:23:08 2005 +++ public_html/ChangeLog Wed Mar 9 08:33:09 2005 @@ -1,3 +1,9 @@ +2005-03-09 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> + + * Added/much improved support for GC-migration of + code-vectors. Should now work well, except for some extreme corner + cases such as the interrupt-trampoline code-vector. + 2005-02-24 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> * Entering an integer at the REPL now invokes the corresponding

1 0

[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp
by ffjeld＠common-lisp.net 09 Mar '05

09 Mar '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv8511 Modified Files: los0-gc.lisp Log Message: Includes testing of code-vector migration. Date: Wed Mar 9 08:31:28 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.48 movitz/losp/los0-gc.lisp:1.49 --- movitz/losp/los0-gc.lisp:1.48 Thu Jan 27 08:48:53 2005 +++ movitz/losp/los0-gc.lisp Wed Mar 9 08:31:28 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.48 2005/01/27 07:48:53 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.49 2005/03/09 07:31:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -335,9 +335,19 @@ (defparameter *x* #4000(nil)) ; Have this in static space. (defparameter *xx* #4000(nil)) ; Have this in static space. +(defparameter *code-vector-foo* 0) +(defvar *old-code-vectors* #250()) +(defvar *new-code-vectors* #250()) + +(defun debug (location x) + (setf (dummy x) + (let ((new (shallow-copy x))) + (warn "[~S] Migrating code-vector ~Z => ~Z." location x new) + new))) (defun stop-and-copy (&optional evacuator) (setf (fill-pointer *x*) 0) + (setf (fill-pointer *old-code-vectors*) 0) (multiple-value-bind (newspace oldspace) (without-interrupts (let* ((space0 (%run-time-context-slot 'nursery-space)) @@ -349,14 +359,37 @@ (setf (%run-time-context-slot 'nursery-space) space1) (values space1 space0))) ;; Evacuate-oldspace is to be mapped over every potential pointer. - (let ((evacuator + (let ((*code-vector-foo* (incf *code-vector-foo* 2)) + (evacuator (or evacuator (lambda (x location) "If x is in oldspace, migrate it to newspace." - (declare (ignore location)) + ;; (declare (ignore location)) (cond ((null x) nil) + ((object-in-space-p newspace x) + x) + ((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))))) ((not (object-in-space-p oldspace x)) x) (t (or (and (eq (object-tag x) @@ -375,47 +408,57 @@ (setf (memref (object-location x) 0) forward-x) forward-x)))))))) ;; Scavenge roots - (dolist (range muerte::%memory-map-roots%) - (map-header-vals evacuator (car range) (cdr range))) - (map-stack-vector evacuator nil (current-stack-frame)) + (with-simple-restart (nil "Scanning stack.") + (map-stack-vector evacuator nil (current-stack-frame))) + (with-simple-restart (nil "Scanning heap.") + (dolist (range muerte::%memory-map-roots%) + (map-header-vals evacuator (car range) (cdr range)))) ;; Scan newspace, Cheney style. - (loop with newspace-location = (+ 2 (object-location newspace)) - with scan-pointer = 2 - as fresh-pointer = (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)) - + (with-simple-restart (nil "Cheney-scanning newspace.") + (loop with newspace-location = (+ 2 (object-location newspace)) + with scan-pointer = 2 + as fresh-pointer = (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))) ;; Consistency check.. + (map-stack-vector (lambda (x foo) + (declare (ignore foo)) + x) + nil + (current-stack-frame)) (when *gc-consitency-check* - (without-interrupts - (let ((a *x*)) - ;; First, restore the state of old-space - (do ((i 0 (+ i 3))) - ((>= i (length a))) - (let ((old (%lispval-object (aref a i))) - (old-class (aref a (+ i 1)))) - (setf (memref (object-location old) 0 :type :unsigned-byte32) old-class))) - ;; Then, check that each migrated object is equalp to its new self. - (do ((i 0 (+ i 3))) - ((>= i (length a))) - (let ((old (%lispval-object (aref a i))) - (new (%lispval-object (aref a (+ i 2))))) - (unless (and (object-in-space-p newspace new) - (object-in-space-p oldspace old) - (objects-equalp old new)) - (let ((*old* old) - (*new* new) - (*old-class* (aref a (+ i 1)))) - (declare (special *old* *new* *old-class*)) - (with-simple-restart (continue "Ignore failed GC consistency check.") + (with-simple-restart (continue "Ignore failed GC consistency check.") + (without-interrupts + (let ((a *x*)) + ;; First, restore the state of old-space + (do ((end (- (length a) 2)) + (i 0 (+ i 3))) + ((>= i end)) + (let ((old (%lispval-object (aref a i))) + (old-class (aref a (+ i 1)))) + (setf (memref (object-location old) 0 :type :unsigned-byte32) old-class))) + ;; Then, check that each migrated object is equalp to its new self. + (do ((i 0 (+ i 3))) + ((>= i (length a))) + (let ((old (%lispval-object (aref a i))) + (new (%lispval-object (aref a (+ i 2))))) + (unless (and (object-in-space-p newspace new) + (not (object-in-space-p newspace old)) + (objects-equalp old new)) + (let ((*evacuator* evacuator) + (*old* old) + (*new* new) + (*old-class* (aref a (+ i 1)))) + (declare (special *old* *new* *old-class* *evacuator*)) (error "GC consistency check failed: old object: ~Z: ~S new object: ~Z: ~S +equalp: ~S oldspace: ~Z, newspace: ~Z, i: ~D" - old old new new oldspace newspace i)))))) + old old new new (objects-equalp old new) oldspace newspace i)))))) (map-header-vals (lambda (x y) (declare (ignore y)) (when (location-in-object-p (space-other (%run-time-context-slot 'nursery-space)) @@ -442,6 +485,10 @@ (location-in-object-p oldspace (object-location o))) (break "Seeing old (unmapped) object ~Z in stack at ~S." o (+ (object-location stack) i 2)))))))) + (loop for o across *old-code-vectors* + for n across *new-code-vectors* + do (setf (memref o 0) (memref n -6)) + (fill (muerte::%location-object o 6) #xcc)) ;; GC completed, oldspace is evacuated. (unless *gc-quiet* (let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2)) @@ -454,9 +501,37 @@ (fill oldspace #x13 :start 2) ;; (setf *gc-stack2* *gc-stack*) (setf *gc-stack* (muerte::copy-current-control-stack)) - (setf (fill-pointer *xx*) (fill-pointer *x*)) - (replace *xx* *x*))) + #+ignore (setf (fill-pointer *xx*) (fill-pointer *x*)) + #+ignore (replace *xx* *x*))) (values)) + +(defun simple-stop-and-copy (newspace oldspace) + (flet ((evacuator (x) + "If x is in oldspace, migrate it to newspace." + (if (not (object-in-space-p oldspace x)) + x + (or (and (eq (object-tag x) + (memref (object-location x) 0 :type :tag)) + (let ((forwarded-x (memref (object-location x) 0))) + (and (object-in-space-p newspace forwarded-x) + forwarded-x))) + (setf (memref (object-location x) 0) + (shallow-copy x)))))) + ;; Scavenge roots + (map-stack-vector #'evacuator nil (current-stack-frame)) + (dolist (range muerte::%memory-map-roots%) + (map-header-vals #'evacuator (car range) (cdr range))) + ;; Scan newspace, Cheney style. + (loop with newspace-location = (+ 2 (object-location newspace)) + with scan-pointer = 2 + as fresh-pointer = (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)) + (initialize-space oldspace) + (values))) (defun find-object-by-location (location &key (continuep t) (breakp nil))

1 0

[movitz-cvs] CVS update: movitz/losp/los0.lisp
by ffjeld＠common-lisp.net 09 Mar '05

09 Mar '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv7945 Modified Files: los0.lisp Log Message: *** empty log message *** Date: Wed Mar 9 08:24:55 2005 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.36 movitz/losp/los0.lisp:1.37 --- movitz/losp/los0.lisp:1.36 Tue Jan 4 21:24:00 2005 +++ movitz/losp/los0.lisp Wed Mar 9 08:24:54 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.36 2005/01/04 20:24:00 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.37 2005/03/09 07:24:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -20,6 +20,7 @@ (require :x86-pc/io-space) (require :x86-pc/ne2k) (require :x86-pc/floppy) +(require :x86-pc/serial) (require :lib/readline) (require :lib/toplevel) @@ -40,7 +41,7 @@ ;; #:muerte.ip6 #:muerte.ip4 #:muerte.mop - #+ignore muerte.x86-pc.serial)) + #:muerte.x86-pc.serial)) (require :los0-gc) ; Must come after defpackage. @@ -1011,7 +1012,8 @@ (if (not (and (boundp '*debugger-condition*) *debugger-condition*)) (fresh-line) - (let ((condition *debugger-condition*)) + (let ((condition *debugger-condition*) + (*print-safely* t)) (cond ((consp condition) (fresh-line) @@ -1141,7 +1143,7 @@ (defun random (limit) (etypecase limit (fixnum - (rem (read-time-stamp-counter) limit)) + (mod (read-time-stamp-counter) limit)) (muerte::positive-bignum (let ((x (muerte::copy-bignum limit))) (dotimes (i (1- (muerte::%bignum-bigits x))) @@ -1210,8 +1212,9 @@ (assert (string= fasit x) () "Failed tesT. Fasit: ~S, X: ~S" fasit x))))) -(defun test-clc (&optional timeout) - (test-timer timeout) +(defun test-clc (&optional timeout no-timer) + (unless no-timer + (test-timer timeout)) (loop (funcall (find-symbol (string :test-clc) :clc)))) @@ -1231,7 +1234,7 @@ ;;; (vector-push funobj ts) ;;; (vector-push offset ts) ;;; (vector-push code-vector ts)))) - (muerte::cli) +;;; (muerte::cli) (pic8259-end-of-interrupt 0) (when (eql #\esc (muerte.x86-pc.keyboard:poll-char)) (break "Test-timer keyboard break.")) @@ -1246,12 +1249,11 @@ (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-header-vals (lambda (x type) - (declare (ignore type)) - x) - (car range) (cdr range))) +;;; (dolist (range muerte::%memory-map-roots%) +;;; (map-header-vals (lambda (x type) +;;; (declare (ignore type)) +;;; x) +;;; (car range) (cdr range))) (map-stack-vector (lambda (x foo) (declare (ignore foo)) x) @@ -1261,11 +1263,12 @@ (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*) (:shrl 2 :ecx) ((:gs-override) :movb #x20 (:ecx 159))) - (setf *timer-prevstack* *timer-stack* - *timer-stack* (muerte::copy-current-control-stack)) + #+ignore (setf *timer-prevstack* *timer-stack* + *timer-stack* (muerte::copy-current-control-stack)) (setf (pit8253-timer-mode 0) +pit8253-mode-single-timeout+ (pit8253-timer-count 0) (or timeout (+ base (random variation)))) - (muerte::sti))) +;;; (muerte::sti) + )) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*) (:shrl 2 :ecx) @@ -1274,24 +1277,10 @@ (pit8253-timer-count 0) (or timeout (+ base (random variation)))) (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) - )) + (with-inline-assembly (:returns :nothing) (:sti))) + +(defun wetweg (x) + (memref-int (memref x 2 :type :unsigned-byte32) :physicalp nil :type :unsigned-byte8)) (defun test-throwing (&optional (x #xffff)) (when x @@ -1338,7 +1327,7 @@ (:jno 'no-overflow) (:movl 4 :eax) no-overflow)) - + (defun genesis () ;; (install-shallow-binding) (let ((extended-memsize 0)) @@ -1352,10 +1341,11 @@ (idt-init) (install-los0-consing :kb-size 500) #+ignore - (install-los0-consing :kb-size (max 100 (truncate (- extended-memsize 2048) 2)))) + (install-los0-consing :kb-size (max 50 (truncate (- extended-memsize 2048) 2)))) (setf *debugger-function* #'los0-debugger) (clos-bootstrap) + (install-shallow-binding) (let ((*repl-readline-context* (make-readline-context :history-size 16)) #+ignore (*backtrace-stack-frame-barrier* (stack-frame-uplink (current-stack-frame))) #+ignore (*error-no-condition-for-debugger* t) @@ -1385,6 +1375,10 @@ *standard-input* s *terminal-io* s *debug-io* s))) +;;; (ignore-errors +;;; (setf (symbol-function 'write-char) +;;; (muerte.x86-pc.serial::make-serial-write-char :baudrate 38400)) +;;; (format t "~&Installed serial-port write-char.")) (let ((* nil) (** nil) (*** nil) (/ nil) (// nil) (/// nil) (+ nil) (++ nil) (+++ nil) @@ -1409,41 +1403,6 @@ (let ((string (muerte.readline:contextual-readline *repl-readline-context*))) (simple-read-from-string string eof-error-p eof-value))) -(defun handle-warning (condition) - (format t "Handle-warning: ~S" condition) - (throw :debugger nil)) - -(defun zoo (x) - (cond - (x (warn "foo")) - (t nil)) - nil) - -#+ignore -(defun progntest () - (prog () - (unwind-protect - (progn - (print 'x) - (go mumbo) - (error "bar")) - (print 'y)) - mumbo)) - -#+ignore -(defun test-restart (x) - (with-simple-restart (test "It's just a test, so ignore ~S." x) - (check-type x symbol))) - -#+ignore -(defun condtest () - (format t "You have two attempts..") - (handler-bind - ((error #'(lambda (c) (print 'x) (warn "An error occurred.."))) - (warning #'handle-warning) - (t #'invoke-debugger)) - (read-eval-print) - (read-eval-print))) #+ignore (defun ztstring (physical-address)

1 0

[movitz-cvs] CVS update: movitz/packages.lisp
by ffjeld＠common-lisp.net 09 Mar '05

09 Mar '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7926 Modified Files: packages.lisp Log Message: *** empty log message *** Date: Wed Mar 9 08:24:37 2005 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.44 movitz/packages.lisp:1.45 --- movitz/packages.lisp:1.44 Fri Feb 25 08:58:26 2005 +++ movitz/packages.lisp Wed Mar 9 08:24:37 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.44 2005/02/25 07:58:26 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.45 2005/03/09 07:24:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1129,6 +1129,7 @@ #:stack-frame-ref #:check-stack-limit #:dit-frame-ref + #:dit-frame-casf #:interrupt-default-handler #:exception-handler

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp
by ffjeld＠common-lisp.net 09 Mar '05

09 Mar '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7905 Modified Files: scavenge.lisp Log Message: Code-vector migration now appears to work. Date: Wed Mar 9 08:24:17 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.48 movitz/losp/muerte/scavenge.lisp:1.49 --- movitz/losp/muerte/scavenge.lisp:1.48 Tue Feb 15 23:22:47 2005 +++ movitz/losp/muerte/scavenge.lisp Wed Mar 9 08:24:16 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.48 2005/02/15 22:22:47 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.49 2005/03/09 07:24:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -90,19 +90,51 @@ (memref scan 0 :type :unsigned-byte32) scan) (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) ;; Process code-vector pointers specially.. - (let* ((funobj (%word-offset scan #.(movitz:tag :other))) - (code-vector (funobj-code-vector funobj)) - (num-jumpers (funobj-num-jumpers funobj))) - (check-type code-vector code-vector) - (map-header-vals function (+ scan 5) (+ scan 7)) ; scan funobj's lambda-list and name - (let ((new-code-vector (funcall function code-vector scan))) - (check-type new-code-vector code-vector) - (unless (eq code-vector new-code-vector) - (error "Code-vector migration is not implemented (~S)." funobj) - (setf (memref scan 0 :index -1) (%word-offset new-code-vector 2)) - ;; Do more stuff here to update code-vectors and jumpers - )) - (incf scan (+ 7 num-jumpers)))) ; Don't scan the jumpers. + (let* ((old-code-vector (memref (incf scan) 0 :type :code-vector)) + (new-code-vector (map-instruction-pointer function scan old-code-vector))) + (cond + ((not (eq new-code-vector old-code-vector)) + ;; Code-vector%1op + (if (location-in-code-vector-p%unsafe old-code-vector + (memref (incf scan) 0 :type :location)) + (map-instruction-pointer function scan old-code-vector) + (map-instruction-pointer function scan)) + ;; Code-vector%2op + (if (location-in-code-vector-p%unsafe old-code-vector + (memref (incf scan) 0 :type :location)) + (map-instruction-pointer function scan old-code-vector) + (map-instruction-pointer function scan)) + ;; Code-vector%3op + (if (location-in-code-vector-p%unsafe old-code-vector + (memref (incf scan) 0 :type :location)) + (map-instruction-pointer function scan old-code-vector) + (map-instruction-pointer function scan)) + ;; lambda-list and name + (map-header-vals function (incf scan) (incf scan 2)) + ;; Jumpers + (let ((num-jumpers (memref scan 0 :type :unsigned-byte14))) + (dotimes (i num-jumpers) + (map-instruction-pointer function (incf scan) old-code-vector)))) + ((eq new-code-vector old-code-vector) + ;; Code-vector%1op + (unless (location-in-code-vector-p%unsafe old-code-vector + (memref (incf scan) 0 :type :location)) + (map-instruction-pointer function scan)) + ;; Code-vector%2op + (unless (location-in-code-vector-p%unsafe old-code-vector + (memref (incf scan) 0 :type :location)) + (map-instruction-pointer function scan)) + ;; Code-vector%3op + (unless (location-in-code-vector-p%unsafe old-code-vector + (memref (incf scan) 0 :type :location)) + (map-instruction-pointer function scan)) + ;; lambda-list and name + (map-header-vals function (incf scan) (incf scan 2)) + ;; Jumpers + (let ((num-jumpers (memref scan 0 :type :unsigned-byte14)) + #+ignore (num-constants (memref scan 2 :type :unsigned-byte16))) + (incf scan num-jumpers) + #+ignore (warn "~D jumpers for ~S, ~S" num-jumpers *scan-last* scan)))))) ((scavenge-typep x :infant-object) (assert (evenp scan) () "Scanned infant ~S at odd location #x~X." x scan) @@ -168,51 +200,54 @@ (+ start-frame 1) map-region)) -(defun scavenge-find-pf (location) +(defun scavenge-match-code-vector (function code-vector location) + "Is location inside code-vector, under evacuator function? +If so, return the actual code-vector pointer that matches." + (if (location-in-code-vector-p%unsafe code-vector location) + code-vector + (let ((fwd (funcall function code-vector nil))) + (check-type fwd code-vector) + (when (location-in-code-vector-p%unsafe fwd location) + fwd)))) + +(defun scavenge-find-pf (function location) (loop for (slot-name type) in (slot-value (class-of (current-run-time-context)) 'slot-map) do (when (eq type 'code-vector-word) - (let ((code-vector (%run-time-context-slot slot-name))) - (when (location-in-object-p code-vector location) - (return code-vector)))))) + (let ((it (scavenge-match-code-vector function (%run-time-context-slot slot-name) location))) + (when it (return it)))))) -(defun scavenge-find-code-vector (location casf-funobj esi &optional primitive-function-p edx) - (flet ((match-funobj (funobj location) +(defun scavenge-find-code-vector (function location casf-funobj esi &optional primitive-function-p edx) + (flet ((match-funobj (function funobj location) (cond ((not (typep funobj 'function)) nil) ((let ((x (funobj-code-vector funobj))) - (and (location-in-object-p x location) x))) + (scavenge-match-code-vector function x location))) ((let ((x (funobj-code-vector%1op funobj))) - (and (typep x 'vector) - (location-in-object-p x location) - x))) + (and (typep x '(not fixnum)) + (scavenge-match-code-vector function x location)))) ((let ((x (funobj-code-vector%2op funobj))) - (and (typep x 'vector) - (location-in-object-p x location) - x))) + (and (typep x '(not fixnum)) + (scavenge-match-code-vector function x location)))) ((let ((x (funobj-code-vector%3op funobj))) - (and (typep x 'vector) - (location-in-object-p x location) - x)))))) + (and (typep x '(not fixnum)) + (scavenge-match-code-vector function x location))))))) (cond - ((location-in-object-p (symbol-value 'ret-trampoline) location) - (symbol-value 'ret-trampoline)) - ((location-in-object-p (%run-time-context-slot 'dynamic-jump-next) location) - (%run-time-context-slot 'dynamic-jump-next)) + ((scavenge-match-code-vector function (symbol-value 'ret-trampoline) location)) + ((scavenge-match-code-vector function (%run-time-context-slot 'dynamic-jump-next) location)) ((eq 0 casf-funobj) (let ((dit-code-vector (symbol-value 'default-interrupt-trampoline))) (cond - ((location-in-object-p dit-code-vector location) - dit-code-vector) - ((match-funobj esi location)) + ((scavenge-match-code-vector function dit-code-vector location)) + ((match-funobj function esi location)) (t (break "DIT returns outside DIT??"))))) - ((match-funobj casf-funobj location)) - ((match-funobj esi location)) - ((match-funobj edx location)) + ((match-funobj function casf-funobj location)) + ((match-funobj function esi location)) + ((match-funobj function edx location)) ((not (typep casf-funobj 'function)) (break "Unknown funobj/frame-type: ~S" casf-funobj)) ((when primitive-function-p - (scavenge-find-pf location) + (scavenge-find-pf function location) #+ignore (%find-code-vector location))) (t (with-simple-restart (continue "Try to perform a code-vector-search.") @@ -243,7 +278,8 @@ ((not (typep frame-funobj 'function)) (error "Unknown stack-frame funobj ~S at ~S" frame-funobj frame)) (t (let* ((old-code-vector - (scavenge-find-code-vector (stack-frame-ref nil eip-index 0 :location) + (scavenge-find-code-vector function + (stack-frame-ref nil eip-index 0 :location) frame-funobj nil nil))) (map-instruction-pointer function eip-index old-code-vector)) (let ((raw-locals (funobj-frame-raw-locals frame-funobj))) @@ -275,11 +311,9 @@ (casf-frame (dit-frame-casf nil dit-frame)) (casf-funobj (map-stack-value function (stack-frame-funobj nil casf-frame) casf-frame)) - (casf-code-vector (map-stack-value function - (case casf-funobj - (0 (symbol-value 'default-interrupt-trampoline)) - (t (funobj-code-vector casf-funobj))) - casf-frame))) + (casf-code-vector (case casf-funobj + (0 (symbol-value 'default-interrupt-trampoline)) + (t (funobj-code-vector casf-funobj))))) ;; 1. Scavenge the dit-frame (cond ((and (not (= 0 atomically)) @@ -301,7 +335,8 @@ (next-frame-bottom (+ dit-frame 1 (dit-frame-index :eflags))) (next-eip-index (+ dit-frame (dit-frame-index :eip))) (old-code-vector - (scavenge-find-code-vector (stack-frame-ref nil eip-index 0 :location) + (scavenge-find-code-vector function + (stack-frame-ref nil eip-index 0 :location) 0 interrupted-esi nil)) (new-code-vector (map-instruction-pointer function eip-index old-code-vector))) @@ -312,17 +347,18 @@ ((and (or (eq x0-tag 1) ; 1 or 5? (eq x0-tag 3) ; 3 or 7? (and (oddp x0-location) (eq x0-tag 2))) ; 6? - (location-in-object-p casf-code-vector x0-location)) + (scavenge-match-code-vector function casf-code-vector x0-location)) (when (= #xc3 (memref-int (stack-frame-ref nil next-eip-index 0 :unsigned-byte32) :physicalp nil :type :unsigned-byte8)) (setf (stack-frame-ref nil next-eip-index 0 :code-vector) (symbol-value 'ret-trampoline))) (let* ((old-x0-code-vector - (scavenge-find-code-vector (stack-frame-ref nil next-eip-index 0 :location) + (scavenge-find-code-vector function + (stack-frame-ref nil next-eip-index 0 :location) casf-funobj interrupted-esi t (unless secondary-register-mode-p (dit-frame-ref nil dit-frame :edx))))) - (map-instruction-pointer function next-eip-index old-x0-code-vector)) + (map-instruction-pointer function next-eip-index old-x0-code-vector dit-frame)) (setf next-eip-index next-frame-bottom next-frame-bottom (1+ next-frame-bottom))) (t (multiple-value-bind (x1-location x1-tag) @@ -330,28 +366,54 @@ (when (and (or (eq x1-tag 1) ; 1 or 5? (eq x1-tag 3) ; 3 or 7? (and (oddp x1-location) (eq x1-tag 2))) ; 6? - (location-in-object-p casf-code-vector x1-location)) + (scavenge-match-code-vector function casf-code-vector x1-location)) (let* ((old-x1-code-vector - (scavenge-find-code-vector (stack-frame-ref nil next-eip-index 0 :location) + (scavenge-find-code-vector function + (stack-frame-ref nil next-eip-index 0 :location) casf-funobj (unless secondary-register-mode-p interrupted-esi) t))) - (map-instruction-pointer function next-eip-index old-x1-code-vector)) + (map-instruction-pointer function next-eip-index old-x1-code-vector dit-frame)) (setf next-eip-index (+ 1 next-frame-bottom) next-frame-bottom (+ 2 next-frame-bottom))))))) ;; proceed (map-stack function casf-frame next-frame-bottom next-eip-index map-region))))) (defun map-instruction-pointer (function location - &optional (old-code-vector (memref location 0 :type :code-vector))) + &optional (old-code-vector (memref location 0 :type :code-vector)) + debug-context) "Update the (raw) instruction-pointer at location, assuming the pointer refers to old-code-vector." - (check-type old-code-vector code-vector) - (assert (location-in-object-p old-code-vector (memref location 0 :type :location))) - (let ((new-code-vector (funcall function old-code-vector nil))) - (when (not (eq old-code-vector new-code-vector)) - (break "Code-vector for stack instruction-pointer moved at location ~S" location)) - new-code-vector)) + ;; (check-type old-code-vector code-vector) ; Can't de-reference old objects.. + (let ((old-ip-location (memref location 0 :type :location))) + (assert (location-in-code-vector-p%unsafe old-code-vector old-ip-location)) + (let ((new-code-vector (funcall function old-code-vector nil))) + (when (not (eq old-code-vector new-code-vector)) + (check-type new-code-vector code-vector) + (let ((location-offset (- old-ip-location (object-location old-code-vector))) + (lowbits (ldb (byte 2 0) (memref location 0 :type :unsigned-byte8)))) + (let ((oeip (memref location 0 :type :unsigned-byte32)) + (neip (+ (* 4 (object-location new-code-vector)) + (* location-offset 4) + lowbits))) + #+ignore + (warn "Instruction-pointer moved at location ~S, old=~S [~S ~S ~S], new=~Z ~S [~S ~S ~S] context ~S" + location + oeip + (memref-int oeip :physicalp nil :type :unsigned-byte8 :offset 0) + (memref-int oeip :physicalp nil :type :unsigned-byte8 :offset 1) + (memref-int oeip :physicalp nil :type :unsigned-byte8 :offset 2) + new-code-vector + neip + (memref-int neip :physicalp nil :type :unsigned-byte8 :offset 0) + (memref-int neip :physicalp nil :type :unsigned-byte8 :offset 1) + (memref-int neip :physicalp nil :type :unsigned-byte8 :offset 2) + debug-context)) + (setf (memref location 0 :type :unsigned-byte32) + (+ (* 4 (object-location new-code-vector)) + (* location-offset 4) + lowbits)))) + new-code-vector)))

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp
by ffjeld＠common-lisp.net 09 Mar '05

09 Mar '05

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv7872 Modified Files: debugger.lisp Log Message: Rename find-function-name to locate-function, and improve it. Date: Wed Mar 9 08:22:32 2005 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.36 movitz/losp/x86-pc/debugger.lisp:1.37 --- movitz/losp/x86-pc/debugger.lisp:1.36 Tue Mar 1 01:41:32 2005 +++ movitz/losp/x86-pc/debugger.lisp Wed Mar 9 08:22:32 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.36 2005/03/01 00:41:32 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.37 2005/03/09 07:22:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -606,39 +606,46 @@ c))))))) (values)) -(defun find-function-name (instruction-location) - "Try to find a name bound to a function whose code-vector matches instruction-location." +(defun locate-function (instruction-location) + "Try to find a function whose code-vector matches instruction-location, or just a code-vector." (check-type instruction-location fixnum) - (or (loop for (slot-name type) in (slot-value (class-of (current-run-time-context)) 'slot-map) - do (when (and (eq type 'code-vector-word) - (location-in-object-p (%run-time-context-slot slot-name) - instruction-location)) - (return (values slot-name :run-time-context)))) - (with-hash-table-iterator (hashis (get-global-property :setf-namespace)) - (do () (nil) - (multiple-value-bind (morep setf-name symbol) - (hashis) - (cond - ((not morep) - (return nil)) - ((and (fboundp symbol) - (location-in-code-vector-p%unsafe (funobj-code-vector (symbol-function symbol)) - instruction-location)) - (return (list 'setf setf-name))))))) - (do-all-symbols (symbol) - (when (fboundp symbol) - (let ((f (symbol-function symbol))) - (when (location-in-code-vector-p%unsafe (funobj-code-vector f) - instruction-location) - (return symbol)) - (when (typep f 'generic-function) - (dolist (m (generic-function-methods f)) - (when (location-in-code-vector-p%unsafe (funobj-code-vector (method-function m)) - instruction-location) - (return-from find-function-name - (funobj-name (method-function m)))))))) - (when (and (boundp symbol) - (typep (symbol-value symbol) 'code-vector) - (location-in-code-vector-p%unsafe (symbol-value symbol) instruction-location)) - (return (values symbol :symbol-value)))))) + (labels ((match-funobj (function instruction-location &optional (limit 5)) + (cond + ((location-in-code-vector-p%unsafe (funobj-code-vector function) + instruction-location) + function) + ((not (plusp limit)) + nil) ; recurse no more. + ;; Search for a local function. + ((loop for i from (funobj-num-jumpers function) below (funobj-num-constants function) + as x = (funobj-constant-ref function i) + thereis (and (typep x 'function) + (match-funobj x instruction-location (1- limit))))) + ;; Search a GF's method functions. + ((when (typep function 'generic-function) + (loop for m in (generic-function-methods function) + thereis (match-funobj (method-function m) instruction-location (1- limit)))))))) + (or (loop for (slot-name type) in (slot-value (class-of (current-run-time-context)) 'slot-map) + do (when (and (eq type 'code-vector-word) + (location-in-object-p (%run-time-context-slot slot-name) + instruction-location)) + (return (values slot-name :run-time-context)))) + (with-hash-table-iterator (hashis (get-global-property :setf-namespace)) + (do () (nil) + (multiple-value-bind (morep setf-name symbol) + (hashis) + (cond + ((not morep) + (return nil)) + ((fboundp symbol) + (let ((it (match-funobj (symbol-function symbol) instruction-location))) + (when it (return it)))))))) + (do-all-symbols (symbol) + (when (fboundp symbol) + (let ((it (match-funobj (symbol-function symbol) instruction-location))) + (when it (return it)))) + (when (and (boundp symbol) + (typep (symbol-value symbol) 'code-vector) + (location-in-code-vector-p%unsafe (symbol-value symbol) instruction-location)) + (return (values symbol :symbol-value)))))))

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/serial.lisp
by ffjeld＠common-lisp.net 09 Mar '05

09 Mar '05

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv7852 Modified Files: serial.lisp Log Message: Some hacking for sending console output to serial port. Date: Wed Mar 9 08:21:42 2005 Author: ffjeld Index: movitz/losp/x86-pc/serial.lisp diff -u movitz/losp/x86-pc/serial.lisp:1.2 movitz/losp/x86-pc/serial.lisp:1.3 --- movitz/losp/x86-pc/serial.lisp:1.2 Thu May 20 20:16:13 2004 +++ movitz/losp/x86-pc/serial.lisp Wed Mar 9 08:21:42 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 11 14:42:12 2002 ;;;; -;;;; $Id: serial.lisp,v 1.2 2004/05/20 18:16:13 ffjeld Exp $ +;;;; $Id: serial.lisp,v 1.3 2005/03/09 07:21:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,7 +18,7 @@ (provide :x86-pc/serial) (defpackage muerte.x86-pc.serial - (:use muerte.cl muerte.lib muerte.x86-pc) + (:use muerte.cl muerte.lib muerte.x86-pc muerte) (:export uart-probe uart-divisor uart-baudrate @@ -147,6 +147,28 @@ ;;;(defun uart-read-char (io-base) ;;; (loop until )) +(defun uart-write-char (io-base char) + (loop until (logbitp 5 (io-register8 io-base +uart-read-lsr+))) + (setf (io-port (+ io-base +uart-write-transmitter-buffer+) :character) + char)) + +(defun make-serial-write-char (&key (io-base (or (some #'uart-probe +uart-probe-addresses+) + (error "No serial port found."))) + (baudrate 9600) + (word-length 8) + (parity :none) + (stop-bits 1)) + (setf (uart-baudrate io-base) baudrate + (io-register8 io-base +uart-write-lcr+) (encode-uart-lcr word-length parity stop-bits)) + (setf (io-register8 io-base +uart-write-fcr+) 0) + (lambda (char &optional stream) + (case char + (#\newline + (uart-write-char io-base #\return))) + (uart-write-char io-base char) + (muerte::%write-char char (muerte::output-stream-designator stream)))) + + (defun com (string &key (io-base (or (some #'uart-probe +uart-probe-addresses+) (error "No serial port found."))) (baudrate 9600) @@ -157,7 +179,6 @@ (io-register8 io-base +uart-write-lcr+) (encode-uart-lcr word-length parity stop-bits)) (setf (io-register8 io-base +uart-write-fcr+) 0) (loop for c across string - do (loop until (logbitp 5 (io-register8 io-base +uart-read-lsr+))) - (setf (io-port (+ io-base +uart-write-transmitter-buffer+) :character) c)) + do (uart-write-char io-base c)) io-base)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp
by ffjeld＠common-lisp.net 09 Mar '05

09 Mar '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7833 Modified Files: interrupt.lisp Log Message: Add (setf dit-frame-ref). Date: Wed Mar 9 08:20:55 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.40 movitz/losp/muerte/interrupt.lisp:1.41 --- movitz/losp/muerte/interrupt.lisp:1.40 Thu Feb 3 10:18:55 2005 +++ movitz/losp/muerte/interrupt.lisp Wed Mar 9 08:20:54 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.40 2005/02/03 09:18:55 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.41 2005/03/09 07:20:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -73,6 +73,10 @@ (eq nil (movitz:movitz-eval stack env)))) form `(setf (memref ,frame (dit-frame-offset ,reg) :type ,type) ,value))) + +(defun (setf dit-frame-ref) (value stack frame reg &optional (type :lisp)) + (setf (stack-frame-ref stack (+ frame (dit-frame-index reg)) 0 type) + value)) (defun dit-frame-casf (stack dit-frame) "Compute the `currently active stack-frame' when the interrupt occurred."

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp
by ffjeld＠common-lisp.net 09 Mar '05

09 Mar '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7810 Modified Files: memref.lisp Log Message: Add :tag as a type for memref. Date: Wed Mar 9 08:19:53 2005 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.43 movitz/losp/muerte/memref.lisp:1.44 --- movitz/losp/muerte/memref.lisp:1.43 Wed Feb 2 08:47:34 2005 +++ movitz/losp/muerte/memref.lisp Wed Mar 9 08:19:53 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.43 2005/02/02 07:47:34 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.44 2005/03/09 07:19:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -83,7 +83,7 @@ `(let ((,object-var ,object) (,offset-var ,offset)) (with-inline-assembly (:returns :untagged-fixnum-ecx - :type (unsigned-byte 16)) + :type (unsigned-byte 8)) (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object-var ,offset-var) ;; (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:movzxb (:eax :ecx ,(offset-by 1)) :ecx) @@ -287,6 +287,28 @@ (:addl :ebx :ecx) (:movl (:eax :ecx ,(offset-by 4)) :ecx) (:andl -4 :ecx))))))) + (:tag + (assert (= 4 movitz::+movitz-fixnum-factor+)) + (cond + ((and (eq 0 offset) (eq 0 index)) + `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 3)) + (:compile-form (:result-mode :eax) ,object) + (:movl (:eax ,(offset-by 4)) :ecx) + (:andl 7 :ecx))) + ((eq 0 offset) + `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 3)) + (:compile-two-forms (:eax :ecx) ,object ,index) + (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (:andl 7 :ecx))) + (t (let ((object-var (gensym "memref-object-"))) + `(let ((,object-var ,object)) + (with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 3)) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :eax) + (:addl :ebx :ecx) + (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (:andl 7 :ecx))))))) (:unsigned-byte32 (let ((endian (movitz:movitz-eval endian env))) (assert (member endian '(:host :little))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/environment.lisp
by ffjeld＠common-lisp.net 09 Mar '05

09 Mar '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7791 Modified Files: environment.lisp Log Message: Be less worried about bignums when computing CPU-cycles in time. Date: Wed Mar 9 08:19:20 2005 Author: ffjeld Index: movitz/losp/muerte/environment.lisp diff -u movitz/losp/muerte/environment.lisp:1.9 movitz/losp/muerte/environment.lisp:1.10 --- movitz/losp/muerte/environment.lisp:1.9 Tue Jan 25 14:45:54 2005 +++ movitz/losp/muerte/environment.lisp Wed Mar 9 08:19:19 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Oct 20 00:41:57 2001 ;;;; -;;;; $Id: environment.lisp,v 1.9 2005/01/25 13:45:54 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.10 2005/03/09 07:19:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -139,13 +139,10 @@ (time-skew-measure start-mem x-lo x-hi)) finally (return x))))) (clumps (and start-mem (- (malloc-cons-pointer) start-mem))) - (delta-hi (- end-time-hi start-time-hi)) - (delta-lo (- end-time-lo start-time-lo skew))) - (if (= 0 delta-hi) - (format t "~&;; CPU cycles: ~D.~@[~%;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~]~%" - delta-lo clumps clumps) - (format t "~&;; CPU cycles: ~DM.~%~@[;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~]~%" - (+ (ash delta-hi 9) (ash delta-lo -20)) clumps clumps))))) + (delta-time (+ (ash (- end-time-hi start-time-hi) 29) + (- end-time-lo start-time-lo skew)))) + (format t "~&;; CPU cycles: ~D.~%~@[;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~]~%" + delta-time clumps clumps)))) (defmacro time (form) `(let ((start-mem (malloc-cons-pointer)))

1 0