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

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 13 Apr '05

13 Apr '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5544 Modified Files: compiler.lisp Log Message: Fixed bug in make-result-and-returns-glue for case :boolean-cf=1 to :ebx, :ecx, etc. Date: Wed Apr 13 09:25:41 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.135 movitz/compiler.lisp:1.136 --- movitz/compiler.lisp:1.135 Sun Feb 27 03:30:22 2005 +++ movitz/compiler.lisp Wed Apr 13 09:25:41 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.135 2005/02/27 02:30:22 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.136 2005/04/13 07:25:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5084,7 +5084,7 @@ (:boolean-cf=1 (values (append code `((:sbbl :ecx :ecx) - (:movl (:edi (:ecx 4) ,(global-constant-offset 'null-cons)) + (:movl (:edi (:ecx 4) ,(global-constant-offset 'not-not-nil)) ,desired-result))) desired-result)) (#.+boolean-modes+

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp
by ffjeld＠common-lisp.net 13 Apr '05

13 Apr '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3835 Modified Files: segments.lisp Log Message: Reworked %sgdt and %lgdt. Date: Wed Apr 13 08:57:02 2005 Author: ffjeld Index: movitz/losp/muerte/segments.lisp diff -u movitz/losp/muerte/segments.lisp:1.6 movitz/losp/muerte/segments.lisp:1.7 --- movitz/losp/muerte/segments.lisp:1.6 Wed Apr 13 08:43:12 2005 +++ movitz/losp/muerte/segments.lisp Wed Apr 13 08:57:01 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu May 8 14:25:06 2003 ;;;; -;;;; $Id: segments.lisp,v 1.6 2005/04/13 06:43:12 ffjeld Exp $ +;;;; $Id: segments.lisp,v 1.7 2005/04/13 06:57:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -55,39 +55,38 @@ Error if the GDT location is not zero modulo 4." (eval-when (:compile-toplevel) (assert (= 4 movitz:+movitz-fixnum-factor+))) - (with-inline-assembly (:returns :multiple-values) - (:pushl #.movitz:+scan-skip-word+) - (:pushl 2) - (:pushl 0) - (:pushl 0) - (:leal (:esp 2) :ecx) - (:sgdt (:ecx)) - (:popl :ecx) - (:shrl 16 :ecx) - (:leal ((:ecx #.movitz::+movitz-fixnum-factor+)) :ebx) - (:popl :ecx) - (:testb 3 :cl) - (:jnz '(:sub-program () - (:compile-form (:result-mode :ignore) - (error "The GDT base is not 4-aligned.")))) - (:movl :ecx :eax) - (:movl 2 :ecx) - (:stc))) + (without-interrupts + (with-inline-assembly (:returns :multiple-values) + (:std) + (:pushl 0) + (:pushl 0) + (:leal (:esp 2) :ecx) + (:sgdt (:ecx)) + (:popl :ebx) + (:shrl #.(cl:- 16 movitz::+movitz-fixnum-shift+) :ebx) + (:andl #.movitz:+movitz-fixnum-zmask+ :ebx) + (:popl :eax) + (:andl #.movitz:+movitz-fixnum-zmask+ :eax) + (:cld) + (:movl 2 :ecx) + (:stc)))) (defun %lgdt (base-location limit) "Set the GDT according to base-location and limit. This is the setter corresponding to the sgdt getter." (eval-when (:compile-toplevel) (assert (= 4 movitz:+movitz-fixnum-factor+))) - (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:eax :ebx) base-location limit) - (:pushl #.movitz:+scan-skip-word+) - (:pushl 2) - (:shll #.(cl:- 16 movitz:+movitz-fixnum-shift+) :ebx) - (:pushl :eax) - (:pushl :ebx) - (:leal (:esp 2) :ecx) - (:lgdt (:ecx)))) + (check-type base-location fixnum) + (check-type limit positive-fixnum) + (without-interrupts + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :push) base-location) + (:compile-form (:result-mode :push) limit) + (:shll #.(cl:- 16 movitz:+movitz-fixnum-shift+) (:esp)) + (:leal (:esp 2) :ecx) + (:lgdt (:ecx)) + (:popl :eax) + (:popl :eax)))) ;;;

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp
by ffjeld＠common-lisp.net 13 Apr '05

13 Apr '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2998 Modified Files: segments.lisp Log Message: Added segment-descriptor-xxx accessors. Date: Wed Apr 13 08:43:14 2005 Author: ffjeld Index: movitz/losp/muerte/segments.lisp diff -u movitz/losp/muerte/segments.lisp:1.5 movitz/losp/muerte/segments.lisp:1.6 --- movitz/losp/muerte/segments.lisp:1.5 Fri Apr 8 08:17:28 2005 +++ movitz/losp/muerte/segments.lisp Wed Apr 13 08:43:12 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu May 8 14:25:06 2003 ;;;; -;;;; $Id: segments.lisp,v 1.5 2005/04/08 06:17:28 ffjeld Exp $ +;;;; $Id: segments.lisp,v 1.6 2005/04/13 06:43:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -50,7 +50,7 @@ (:gs (set-sreg :gs)))) value) -(defun sgdt () +(defun %sgdt () "Return the location of the GDT, and the limit. Error if the GDT location is not zero modulo 4." (eval-when (:compile-toplevel) @@ -74,7 +74,7 @@ (:movl 2 :ecx) (:stc))) -(defun lgdt (base-location limit) +(defun %lgdt (base-location limit) "Set the GDT according to base-location and limit. This is the setter corresponding to the sgdt getter." (eval-when (:compile-toplevel) @@ -162,4 +162,67 @@ (:cr4 (set-creg :cr4))) value)) - +(defun segment-descriptor-base (table index) + (check-type table (and vector (not simple-vector))) + (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)))) + (logior (ash (memref table (+ 7 offset) :type :unsigned-byte8) + 24) + (ash (memref table (+ 4 offset) :type :unsigned-byte16) + 16) + (ash (memref table (+ 2 offset) :type :unsigned-byte16) + 0)))) + +(defun (setf segment-descriptor-base) (base table index) + (check-type table (and vector (not simple-vector))) + (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)))) + (setf (memref table (+ 7 offset) :type :unsigned-byte8) + (ldb (byte 8 24) base)) + (setf (memref table (+ 4 offset) :type :unsigned-byte8) + (ldb (byte 8 16) base)) + (setf (memref table (+ 2 offset) :type :unsigned-byte16) + (ldb (byte 16 0) base)) + base)) + +(defun segment-descriptor-limit (table index) + (check-type table (and vector (not simple-vector))) + (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)))) + (dpb (memref table (+ 6 offset) :type :unsigned-byte8) + (byte 4 16) + (memref table (+ 0 offset) :type :unsigned-byte16)))) + +(defun (setf segment-descriptor-limit) (limit table index) + (check-type table (and vector (not simple-vector))) + (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)))) + (setf (memref table (+ 6 offset) :type :unsigned-byte8) + (ldb (byte 4 16) limit)) + (setf (memref table (+ 0 offset) :type :unsigned-byte8) + (ldb (byte 16 0) limit)) + limit)) + +(defun segment-descriptor-type-s-dpl-p (table index) + "Access bits 40-47 of the segment descriptor." + (check-type table (and vector (not simple-vector))) + (memref table (+ 5 (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)) + :type :unsigned-byte8)) + +(defun (setf segment-descriptor-type-s-dpl-p) (bits table index) + "Access bits 40-47 of the segment descriptor." + (check-type table (and vector (not simple-vector))) + (setf (memref table (+ 5 (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)) + :type :unsigned-byte8) + bits)) + +(defun segment-descriptor-avl-x-db-g (table index) + "Access bits 52-55 of the segment descriptor." + (check-type table (and vector (not simple-vector))) + (ldb (byte 4 4) + (memref table (+ 5 (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)) + :type :unsigned-byte8))) + +(defun (setf segment-descriptor-avl-x-db-g) (bits table index) + "Access bits 52-55 of the segment descriptor." + (check-type table (and vector (not simple-vector))) + (setf (ldb (byte 4 4) + (memref table (+ 5 (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)) + :type :unsigned-byte8)) + bits))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp
by ffjeld＠common-lisp.net 08 Apr '05

08 Apr '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3249 Modified Files: segments.lisp Log Message: *** empty log message *** Date: Fri Apr 8 08:17:29 2005 Author: ffjeld Index: movitz/losp/muerte/segments.lisp diff -u movitz/losp/muerte/segments.lisp:1.4 movitz/losp/muerte/segments.lisp:1.5 --- movitz/losp/muerte/segments.lisp:1.4 Thu Oct 21 22:51:13 2004 +++ movitz/losp/muerte/segments.lisp Fri Apr 8 08:17:28 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001, 2003-2004, +;;;; Copyright (C) 2001, 2003-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: Thu May 8 14:25:06 2003 ;;;; -;;;; $Id: segments.lisp,v 1.4 2004/10/21 20:51:13 ffjeld Exp $ +;;;; $Id: segments.lisp,v 1.5 2005/04/08 06:17:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,13 +18,13 @@ (in-package muerte) -(defun segment-register (segment-register) +(defun segment-register-name (segment-register-name) "Return the value of an x86 segment register, such as :cs or :ds." (macrolet ((sreg (reg) `(with-inline-assembly (:returns :untagged-fixnum-ecx) (:xorl :ecx :ecx) (:movw ,reg :cx)))) - (ecase segment-register + (ecase segment-register-name (:ss (sreg :ss)) (:cs (sreg :cs)) (:ds (sreg :ds)) @@ -32,7 +32,7 @@ (:fs (sreg :fs)) (:gs (sreg :gs))))) -(defun (setf segment-register) (value segment-register) +(defun (setf segment-register-name) (value segment-register-name) "This function indiscriminately sets a segment register, which is a great way to crash the machine. So know what you're doing." (check-type value (unsigned-byte 16)) @@ -41,7 +41,7 @@ (:compile-form (:result-mode :ecx) value) (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) (:movw :cx ,reg)))) - (ecase segment-register + (ecase segment-register-name (:ss (set-sreg :ss)) (:cs (set-sreg :cs)) (:ds (set-sreg :ds))

1 0

[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