movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[movitz-cvs] CVS update: ia-x86/codec.lisp
by Frode Vatvedt Fjeld 02 Sep '04

02 Sep '04

Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv12156 Modified Files: codec.lisp Log Message: Added a protocol for adding "extra" prefixes (such as NOPs) to instructions as they are inserted in a code-stream. This is needed for Movitz to be able to align call instructions such that return-addresses are distinguisable from immediate values, which is required by stack discipline. Date: Thu Sep 2 11:01:20 2004 Author: ffjeld Index: ia-x86/codec.lisp diff -u ia-x86/codec.lisp:1.5 ia-x86/codec.lisp:1.6 --- ia-x86/codec.lisp:1.5 Tue Feb 10 01:03:14 2004 +++ ia-x86/codec.lisp Thu Sep 2 11:01:19 2004 @@ -1,15 +1,15 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 20012000, 2002, 2004, +;;;; Copyright (C) 2000, 2001, 2002, 2004, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: codec.lisp -;;;; Description: +;;;; Description: Encoding and decoding of instructions to/from binary. ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu May 4 15:16:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: codec.lisp,v 1.5 2004/02/10 00:03:14 ffjeld Exp $ +;;;; $Id: codec.lisp,v 1.6 2004/09/02 09:01:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -428,9 +428,11 @@ -(defun template-instr-and-prefix-length (template instr) +(defun template-instr-and-prefix-length (template instr env) (+ (template-instr-numo template) - (length (calculate-prefixes instr template)))) + (length (calculate-prefixes instr template)) + (length (compute-instruction-extra-prefixes instr template env)))) + ;;; ---------------------------------------------------------------- ;;; Instruction decode @@ -454,8 +456,8 @@ (defun make-decode-instruction (datum prefixes template) (instruction-decode (make-instance (template-instr-classname template) - 'datum datum - 'prefixes (set-difference prefixes + :datum datum + :prefixes (set-difference prefixes (template-req-prefixes template))) template)) @@ -473,18 +475,22 @@ (set-difference (instruction-prefixes instr) (template-not-prefixes template))))) -(defun prefix-encode (prefix-list cdatum) +(defun prefix-encode (cdatum prefix-list &optional extra-prefixes) "Given an instruction encoded into <cdatum> by <template>, append the necessary prefix-bytes to cdatum." (let ((new-byte (realpart cdatum)) (byte-pos (imagpart cdatum))) (loop for prefix in prefix-list - do (progn - (setf (ldb (byte 8 (* 8 byte-pos)) - new-byte) + do (setf (ldb (byte 8 (* 8 byte-pos)) + new-byte) (decode-set +prefix-opcode-map+ prefix)) - (incf byte-pos))) + (incf byte-pos)) + (loop for prefix in extra-prefixes + do (setf (ldb (byte 8 (* 8 byte-pos)) + new-byte) + prefix) + (incf byte-pos)) (complex new-byte byte-pos))) (defun make-instr-symbolic-from-template (template) @@ -539,8 +545,10 @@ :encoding-list (mapcar #'operand-class-encoding (template-instr-operand-classes template)) :template template)) - -(defun instruction-encode-from-teo (instr teo) + +(defvar *instruction-compute-extra-prefix-map* nil) + +(defun instruction-encode-from-teo (instr teo env) (check-type instr instruction) (let ((template (teo-template teo)) (resolved-operand-list (teo-resolved-operand-list teo)) @@ -550,9 +558,17 @@ and operand-encoding in operand-encoding-list and operand-type in (template-instr-operand-types template) do (operand-encode operand operand-encoding operand-type is)) - (prefix-encode (calculate-prefixes instr template) - (encode-instr-symbolic template is))))) - + (prefix-encode (encode-instr-symbolic template is) + (calculate-prefixes instr template) + (compute-instruction-extra-prefixes instr template env))))) + +(defun compute-instruction-extra-prefixes (instr template env) + (funcall (or (instruction-finalizer instr) + (cdr (assoc (class-name (class-of instr)) *instruction-compute-extra-prefix-map* + :test #'string=)) + (constantly nil)) + instr env (+ (template-instr-numo template) + (length (calculate-prefixes instr template))))) (defun template-match-by-cpu-mode (template cpu-mode) (or (eq :any-mode (template-cpu-mode template)) @@ -580,13 +596,16 @@ (setf chosen-teo teo)) finally (return chosen-teo))) -(defun optimize-teo-smallest (teo-list instr) +(defun optimize-teo-smallest (teo-list instr env) "Prefer the smallest (as in fewest octets) encodings." + (declare (ignore env)) (pairwise-teopt teo-list instr #'(lambda (teo1 teo2 instr) - (< (template-instr-and-prefix-length (teo-template teo1) instr) - (template-instr-and-prefix-length (teo-template teo2) instr))))) + (< (+ (template-instr-numo (teo-template teo1)) + (length (calculate-prefixes instr (teo-template teo1)))) + (+ (template-instr-numo (teo-template teo2)) + (length (calculate-prefixes instr (teo-template teo2)))))))) (defun template-is-16-bit-p (template) (or (eq :16-bit (template-addressing-mode template)) @@ -594,8 +613,9 @@ (member '16-bit-operand (template-req-prefixes template)) (member '16-bit-address (template-req-prefixes template)))) -(defun optimize-teo-smallest-no16 (teo-list instr) +(defun optimize-teo-smallest-no16 (teo-list instr env) "Prefer the smallest 32-bit encoding." + (declare (ignore env)) (pairwise-teopt teo-list instr #'(lambda (teo1 teo2 instr) @@ -603,40 +623,38 @@ (t2 (teo-template teo2))) (or (and (not (template-is-16-bit-p t1)) (template-is-16-bit-p t2)) - #+ignore (and (null (intersection '(16-bit-operand 16-bit-address) - (template-req-prefixes t1))) - (intersection '(16-bit-operand 16-bit-address) - (template-req-prefixes t2))) - (< (template-instr-and-prefix-length t1 instr) - (template-instr-and-prefix-length t2 instr))))))) + (< (+ (template-instr-numo t1) + (length (calculate-prefixes instr t1))) + (+ (template-instr-numo t2) + (length (calculate-prefixes instr t2))))))))) -(defun optimize-teo-original-size (teo-list instr) +(defun optimize-teo-original-size (teo-list instr env) "Find an encoding that matches the size of the instruction's original size (its instruction-original-datum)." (let ((original-size (imagpart (instruction-original-datum instr)))) (find-if #'(lambda (teo) (= original-size - (template-instr-and-prefix-length (teo-template teo) instr))) + (template-instr-and-prefix-length (teo-template teo) instr env))) teo-list))) -(defun optimize-teo-user-size (teo-list instr) +(defun optimize-teo-user-size (teo-list instr env) "Find an encoding that matches the user-specified size." (find-if #'(lambda (teo) (= (instruction-user-size instr) - (template-instr-and-prefix-length (teo-template teo) instr))) + (template-instr-and-prefix-length (teo-template teo) instr env))) teo-list)) -(defun instruction-encode (instr &optional env (optimize-teo-fn #'optimize-teo-smallest)) +(defun instruction-encode (instr env &optional (optimize-teo-fn #'optimize-teo-smallest)) (let ((teo-list (instruction-encode-to-teo instr env))) (if (null teo-list) (error "Unable to encode ~A." instr) (let ((teo (if (instruction-user-size instr) - (optimize-teo-user-size teo-list instr) - (funcall optimize-teo-fn teo-list instr)))) + (optimize-teo-user-size teo-list instr env) + (funcall optimize-teo-fn teo-list instr env)))) (if (not (teo-p teo)) (error "Optimization with ~S of instruction ~S failed for teo-list ~S" optimize-teo-fn instr teo-list) - (instruction-encode-from-teo instr teo)))))) + (instruction-encode-from-teo instr teo env)))))) ;;;

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp
by Frode Vatvedt Fjeld 30 Aug '04

30 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10728 Modified Files: inspect.lisp Log Message: Fixed keyword typo. Date: Mon Aug 30 17:16:59 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.35 movitz/losp/muerte/inspect.lisp:1.36 --- movitz/losp/muerte/inspect.lisp:1.35 Mon Aug 23 15:58:25 2004 +++ movitz/losp/muerte/inspect.lisp Mon Aug 30 17:16:59 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.35 2004/08/23 13:58:25 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.36 2004/08/30 15:16:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -84,14 +84,14 @@ (t (memref frame 0 index type)))) (defun current-dynamic-context () - (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)))) + (with-inline-assembly (:returns :eax) + (:locally (:movl (:edi (:edi-offset dynamic-env)) :eax)))) (defun dynamic-context-uplink (dynamic-context) - (stack-ref dynamic-context 12 0 :unsigned-byte32)) + (stack-frame-ref nil dynamic-context 3 :lisp)) (defun dynamic-context-tag (dynamic-context) - (stack-ref dynamic-context 4 0 :lisp)) + (stack-frame-ref nil dynamic-context 1 :lisp)) (defmacro with-each-dynamic-context ((&optional start-context result) &rest clauses) "Only use this if you know what you're doing. See run-time.lisp." @@ -103,15 +103,15 @@ (basic-restart-clause (find :basic-restart clauses :key #'caar))) `(do ((,context ,(if start-context start-context '(current-dynamic-context)) (dynamic-context-uplink ,context))) - ((not (stack-ref-p ,context)) ,result) + ((not (plusp ,context)) ,result) (let ((,tag (dynamic-context-tag ,context))) (cond ,@(when bind-clause `(((eq ,tag (load-global-constant unbound-value)) (multiple-value-bind ,(cdar bind-clause) (values ,context - (stack-ref ,context 0 0 :lisp) - (stack-ref ,context 8 0 :lisp)) + (stack-frame-ref nil ,context 0 :lisp) + (stack-frame-ref nil ,context 2 :lisp)) ,@(rest bind-clause))))) ,@(when up-clause `(((eq ,tag (load-global-constant unwind-protect-tag)) @@ -120,14 +120,14 @@ ,@(rest up-clause))))) ,@(when basic-restart-clause `(((eq ,tag (load-global-constant restart-tag)) - (macrolet ((rc-function (c) `(stack-ref ,c 0 -2 :lisp)) - (rc-interactive (c) `(stack-ref ,c 0 -3 :lisp)) - (rc-test (c) `(stack-ref ,c 0 -4 :lisp)) - (rc-format (c) `(stack-ref ,c 0 -5 :lisp)) - (rc-args (c) `(stack-ref ,c 0 -6 :lisp))) + (macrolet ((rc-function (c) `(stack-frame-ref nil ,c -2 :lisp)) + (rc-interactive (c) `(stack-frame-ref nil ,c -3 :lisp)) + (rc-test (c) `(stack-frame-ref nil ,c -4 :lisp)) + (rc-format (c) `(stack-frame-ref nil ,c -5 :lisp)) + (rc-args (c) `(stack-frame-ref nil ,c -6 :lisp))) (multiple-value-bind ,(cdar basic-restart-clause) (values ,@(subseq `(,context - (stack-ref ,context 0 -1 :lisp)) ; name + (stack-frame-ref nil ,context -1 :lisp)) ; name 0 (length (cdar basic-restart-clause)))) ,@(rest basic-restart-clause)))))) ,@(when catch-clause @@ -135,13 +135,12 @@ (values ,context ,tag) ,@(rest catch-clause)))))))))) -#+ignore (defun pdc (&rest types) (declare (dynamic-extent types)) (let ((types (or types '(:restarts :bindings :catch)))) (with-each-dynamic-context () ((:basic-restart context name) - (when (member :restart types) + (when (member :restarts types) (format t "~&restart: ~S fmt: ~S/~S [#x~X]" name (rc-format context) (rc-args context)

1 0

[movitz-cvs] CVS update: movitz/procfs-image.lisp
by Frode Vatvedt Fjeld 30 Aug '04

30 Aug '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5363 Modified Files: procfs-image.lisp Log Message: Changed format of dit-frames, reflect this in the procfs debugger too. Date: Mon Aug 30 16:59:23 2004 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.17 movitz/procfs-image.lisp:1.18 --- movitz/procfs-image.lisp:1.17 Mon Aug 23 15:46:18 2004 +++ movitz/procfs-image.lisp Mon Aug 30 16:59:23 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.17 2004/08/23 13:46:18 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.18 2004/08/30 14:59:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -167,8 +167,7 @@ (defun interrupt-frame-index (name) (- 5 (position name - '(nil :eflags :eip :error-code :exception :ebp nil - :ecx :eax :edx :ebx :esi :edi)))) + (symbol-value 'muerte::+dit-frame-map+)))) (defun debug-get-object (word spartan) (if spartan @@ -202,7 +201,8 @@ (edi (get-word (+ (* 4 (interrupt-frame-index :edi)) stack-frame))) (eip (get-word (+ (* 4 (interrupt-frame-index :eip)) stack-frame))) (esi (get-word (+ (* 4 (interrupt-frame-index :esi)) stack-frame))) - (exception (get-word (+ (* 4 (interrupt-frame-index :exception)) stack-frame)))) + (exception (get-word (+ (* 4 (interrupt-frame-index :exception-vector)) + stack-frame)))) (format t "#x~X {EAX: #x~X, ECX: #x~X, EDX: #x~X, EDI: #x~X, ESI: #x~X, EIP: #x~X, exception ~D}" stack-frame eax ecx edx edi esi eip exception)))

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp
by Frode Vatvedt Fjeld 23 Aug '04

23 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv11425 Modified Files: debugger.lisp Log Message: Changed the way stack locations are represented: Rather than merely a 'location' (which is a simple pointer, and so GC-unsafe), we now use two values: a vector and an index. If vector is non-nil, index is a an index into the vector. If vector is nil, index is a location (as before), typically referencing the currently active stack, which won't move (but probably this mode should be deprecated). Date: Mon Aug 23 06:58:41 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.21 movitz/losp/x86-pc/debugger.lisp:1.22 --- movitz/losp/x86-pc/debugger.lisp:1.21 Thu Aug 12 10:45:39 2004 +++ movitz/losp/x86-pc/debugger.lisp Mon Aug 23 06:58:41 2004 @@ -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.21 2004/08/12 17:45:39 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.22 2004/08/23 13:58:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -121,18 +121,19 @@ (:ecx . (#xff #x56 #.(cl:ldb (cl:byte 8 0) (bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector)))))) -(defun stack-frame-numargs (stack-frame) +(defun stack-frame-numargs (stack frame) "Try to determine how many arguments was presented to the stack-frame." - (if (eq (stack-frame-funobj stack-frame) + (if (eq (stack-frame-funobj stack frame) (load-global-constant complicated-class-of)) 1 - (multiple-value-bind (call-site code) - (stack-frame-call-site stack-frame) + (multiple-value-bind (call-site code funobj) + (stack-frame-call-site stack frame) (when (and call-site code) (dolist (map +call-site-numargs-maps+ - (warn "no match at ~D for ~S." + (warn "no match at ~D for ~S frame ~S [~S]." call-site - (stack-frame-funobj (stack-frame-uplink stack-frame)))) + (stack-frame-funobj stack (stack-frame-uplink stack frame)) + frame funobj)) (when (not (mismatch code (cdr map) :start1 (- call-site (length (cdr map))) :end1 call-site)) @@ -262,17 +263,17 @@ #xff #x56 (:code-vector)))) ; #<asm CALL [#x6+%ESI]> )) -(defun call-site-find (stack-frame register) +(defun call-site-find (stack frame register) "Based on call-site's code, figure out where eax and ebx might be located in the caller's stack-frame or funobj-constants." (macrolet ((success (result) `(return-from call-site-find (values ,result t)))) (multiple-value-bind (call-site-ip code-vector funobj) - (stack-frame-call-site stack-frame) + (stack-frame-call-site stack frame) (when (eq funobj #'apply) - (let ((apply-frame (stack-frame-uplink stack-frame))) - (when (eq 2 (stack-frame-numargs apply-frame)) - (let ((applied (call-site-find apply-frame :ebx))) + (let ((apply-frame (stack-frame-uplink stack frame))) + (when (eq 2 (stack-frame-numargs stack apply-frame)) + (let ((applied (call-site-find stack apply-frame :ebx))) ;; (warn "reg: ~S, applied: ~S" register applied) (case register (:eax (success (first applied))) @@ -287,7 +288,8 @@ (:constant (success result-position)) (:ebp - (success (stack-frame-ref (stack-frame-uplink stack-frame) + (success (stack-frame-ref stack + (stack-frame-uplink stack frame) (signed8-index result-position)))) (:esi (when funobj @@ -297,7 +299,7 @@ #.(bt:slot-offset 'movitz::movitz-funobj 'movitz::constant0))))))) (:esp - (success (stack-frame-ref stack-frame + (success (stack-frame-ref stack frame (+ 2 (signed8-index result-position)))))))))))))) (defparameter *stack-frame-setup-patterns* @@ -357,17 +359,17 @@ (when (match-code-pattern (car pattern-map) code-vector setup-start) (return pattern-map)))))) -(defun print-stack-frame-arglist (stack-frame stack-frame-map - &key (numargs (stack-frame-numargs stack-frame)) +(defun print-stack-frame-arglist (stack frame stack-frame-map + &key (numargs (stack-frame-numargs stack frame)) (edx-p nil)) - (flet ((stack-frame-register-value (register stack-frame stack-map-pos) + (flet ((stack-frame-register-value (stack frame register stack-map-pos) (multiple-value-bind (val success-p) - (call-site-find stack-frame register) + (call-site-find stack frame register) (cond (success-p (values val t)) (stack-map-pos - (values (stack-frame-ref stack-frame stack-map-pos) + (values (stack-frame-ref stack frame stack-map-pos) t)) (t (values nil nil))))) (debug-write (x) @@ -389,7 +391,7 @@ (write-string " ...") (prog () ;; (numargs (min numargs *backtrace-max-args*))) (multiple-value-bind (edx foundp) - (stack-frame-register-value :edx stack-frame (pop stack-frame-map)) + (stack-frame-register-value stack frame :edx (pop stack-frame-map)) (when edx-p (write-string " {edx: ") (if foundp @@ -400,9 +402,9 @@ (return)) (write-char #\space) (if (first stack-frame-map) - (debug-write (stack-frame-ref stack-frame (first stack-frame-map))) + (debug-write (stack-frame-ref stack frame (first stack-frame-map))) (multiple-value-bind (eax eax-p) - (call-site-find stack-frame :eax) + (call-site-find stack frame :eax) (if eax-p (debug-write eax) (write-string "{eax unknown}")))) @@ -410,9 +412,9 @@ (return)) (write-char #\space) (if (second stack-frame-map) - (debug-write (stack-frame-ref stack-frame (second stack-frame-map))) + (debug-write (stack-frame-ref stack frame (second stack-frame-map))) (multiple-value-bind (ebx ebx-p) - (call-site-find stack-frame :ebx) + (call-site-find stack frame :ebx) (if ebx-p (debug-write ebx) (write-string "{ebx unknown}")))) @@ -422,7 +424,7 @@ (write-string " ...") (return)) (write-char #\space) - (debug-write (stack-frame-ref stack-frame i)))))) + (debug-write (stack-frame-ref stack frame i)))))) (values)) (defun safe-print-stack-frame-arglist (&rest args) @@ -432,11 +434,17 @@ (declare (ignore conditon)) (write-string "#<error printing frame>")))) -(defun backtrace (&key stack - ((:frame initial-stack-frame) - (or (and stack (svref%unsafe stack 0)) - *debugger-invoked-stack-frame* - (current-stack-frame))) +(defun location-index (vector location) + (assert (location-in-object-p vector location)) + (- location (object-location vector) 2)) + +(defun backtrace (&key (stack nil) + ((:frame initial-stack-frame-index) + (if stack + (stack-frame-ref stack 0 0) + (or *debugger-invoked-stack-frame* + (current-stack-frame)))) + ;; (relative-uplinks (not (eq stack (%run-time-context-slot 'stack-vector)))) ((:spartan *backtrace-be-spartan-p*)) ((:fresh-lines *backtrace-do-fresh-lines*) *backtrace-do-fresh-lines*) (conflate *backtrace-do-conflate*) @@ -448,13 +456,14 @@ (*print-length* *backtrace-print-length*) (*print-level* *backtrace-print-level*)) (loop with conflate-count = 0 with count = 0 - for stack-frame = initial-stack-frame - then (let ((uplink (stack-frame-uplink stack-frame))) - (assert (> uplink stack-frame) () - "Backtracing uplink ~S from frame ~S." uplink stack-frame) + for frame = initial-stack-frame-index + then (let ((uplink (stack-frame-uplink stack frame))) + (assert (> uplink frame) () + "Backtracing uplink ~S from frame index ~S." uplink frame) uplink) - as funobj = (stack-frame-funobj stack-frame t) - do (flet ((print-leadin (stack-frame count conflate-count) + ;; as xxx = (warn "frame: ~S" frame) + as funobj = (stack-frame-funobj stack frame) + do (flet ((print-leadin (stack frame count conflate-count) (when *backtrace-do-fresh-lines* (fresh-line)) (cond @@ -466,13 +475,13 @@ (write-char #\space)) (t (format t "~& |= "))) (when print-returns - (format t "{< ~D}" (stack-frame-call-site stack-frame))) + (format t "{< ~D}" (stack-frame-call-site stack frame))) (when *backtrace-print-frames* - (format t "#x~X " stack-frame)))) + (format t "#x~X " frame)))) (typecase funobj - (integer - (let* ((interrupt-frame stack-frame) - (funobj (dit-frame-ref :esi :lisp 0 interrupt-frame))) + ((eql 0) + (let* ((dit-frame (if (null stack) frame (+ frame 2 (object-location stack)))) + (funobj (dit-frame-ref :esi :lisp 0 dit-frame))) (if (and conflate-interrupts conflate ;; When the interrupted function has a stack-frame, conflate it. (typep funobj 'function) @@ -480,55 +489,55 @@ (incf conflate-count) (progn (incf count) - (print-leadin stack-frame count conflate-count) + (print-leadin stack frame count conflate-count) (setf conflate-count 0) (let ((exception (dit-frame-ref :exception-vector :unsigned-byte32 - 0 interrupt-frame)) + 0 dit-frame)) (eip (dit-frame-ref :eip :unsigned-byte32 - 0 interrupt-frame))) + 0 dit-frame))) (typecase funobj (function (let ((delta (code-vector-offset (funobj-code-vector funobj) eip))) (if delta (format t "{Exception ~D in ~W at PC offset ~D." exception (funobj-name funobj) delta) - (format t "{Exception ~D in ~W at EIP=#x~X. [#x~X]}" - exception (funobj-name funobj) eip interrupt-frame)))) - (t (format t "{Exception ~D with ESI=#x~Z and EIP=#x~X. [#x~X]}" - exception funobj eip interrupt-frame)))))))) + (format t "{Exception ~D in ~W at EIP=#x~X.}" + exception (funobj-name funobj) eip)))) + (t (format t "{Exception ~D with ESI=~Z and EIP=#x~X.}" + exception funobj eip)))))))) (function (let ((name (funobj-name funobj))) (cond ((and conflate (member name *backtrace-conflate-names* :test #'equal)) (incf conflate-count)) (t (incf count) - (when (and *backtrace-stack-frame-barrier* - (<= *backtrace-stack-frame-barrier* stack-frame)) - (write-string " --|") - (return)) + #+ignore (when (and *backtrace-stack-frame-barrier* + (<= *backtrace-stack-frame-barrier* stack-frame)) + (write-string " --|") + (return)) (unless (or (not (integerp length)) (< count length)) (write-string " ...") (return)) - (print-leadin stack-frame count conflate-count) + (print-leadin stack frame count conflate-count) (setf conflate-count 0) (write-char #\() - (let* ((numargs (stack-frame-numargs stack-frame)) + (let* ((numargs (stack-frame-numargs stack frame)) (map (and funobj (funobj-stack-frame-map funobj numargs)))) (cond ((and (car map) (eq name 'unbound-function)) - (let ((real-name (stack-frame-ref stack-frame (car map)))) + (let ((real-name (stack-frame-ref stack frame (car map)))) (format t "{unbound ~S}" real-name))) ((and (car map) (member name +backtrace-gf-discriminatior-functions+)) - (let ((gf (stack-frame-ref stack-frame (car map)))) + (let ((gf (stack-frame-ref stack frame (car map)))) (cond ((typep gf 'muerte::standard-gf-instance) (format t "{gf ~S}" (funobj-name gf))) (t (write-string "[not a gf??]"))) - (safe-print-stack-frame-arglist stack-frame map :numargs numargs))) + (safe-print-stack-frame-arglist stack frame map :numargs numargs))) (t (write name) - (safe-print-stack-frame-arglist stack-frame map + (safe-print-stack-frame-arglist stack frame map :numargs numargs :edx-p (eq 'muerte::&edx (car (funobj-lambda-list funobj)))))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp
by Frode Vatvedt Fjeld 23 Aug '04

23 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9367 Modified Files: scavenge.lisp Log Message: Changed the way stack locations are represented: Rather than merely a 'location' (which is a simple pointer, and so GC-unsafe), we now use two values: a vector and an index. If vector is non-nil, index is a an index into the vector. If vector is nil, index is a location (as before), typically referencing the currently active stack, which won't move (but probably this mode should be deprecated). Date: Mon Aug 23 06:58:35 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.26 movitz/losp/muerte/scavenge.lisp:1.27 --- movitz/losp/muerte/scavenge.lisp:1.26 Thu Aug 12 10:11:55 2004 +++ movitz/losp/muerte/scavenge.lisp Mon Aug 23 06:58:34 2004 @@ -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.26 2004/08/12 17:11:55 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.27 2004/08/23 13:58:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -35,42 +35,34 @@ start-location and end-location." (macrolet ((scavenge-typep (x primary) (let ((code (movitz:tag primary))) - `(with-inline-assembly (:returns :boolean-zf=1) - (:compile-form (:result-mode :eax) ,x) - (:cmpb ,code :al)))) + `(= ,code (ldb (byte 8 0) ,x)))) (scavenge-wide-typep (x primary secondary) (let ((code (dpb secondary (byte 8 8) (movitz:tag primary)))) - `(with-inline-assembly (:returns :boolean-zf=1) - (:compile-form (:result-mode :eax) ,x) - (:cmpw ,code :ax)))) - (word-bigits (x) - "If x is a bignum header word, return the number of bigits." - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) ,x) - (:shrl 16 :eax) - (:testb ,movitz:+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program () (:int 63)))))) + `(= ,code ,x)))) (do ((verbose *map-heap-words-verbose*) (*scan-last* nil) ; Last scanned object, for debugging. (scan start-location (1+ scan))) ((>= scan end-location)) (declare (special *scan-last*)) (let ((*scan* scan) - (x (memref scan 0 0 :lisp))) + (x (memref scan 0 0 :unsigned-byte16))) (declare (special *scan*)) (when verbose - (format *terminal-io* "~&MHW scanning at ~S: ~Z" scan x)) + (format *terminal-io* " [at ~S: ~S]" scan x)) (cond - ((typep x '(or null fixnum character))) + ((let ((tag (ldb (byte 3 0) x))) + (or (= tag #.(movitz:tag :null)) + (= tag #.(movitz:tag :fixnum)) + (scavenge-typep x :character)))) ((scavenge-typep x :illegal) - (error "Illegal word ~Z at ~S." x scan)) + (error "Illegal word ~S at ~S." x scan)) ((scavenge-typep x :bignum) (assert (evenp scan) () - "Scanned ~Z at odd location #x~X." x scan) + "Scanned ~S at odd location #x~X." x scan) ;; Just skip the bigits - (let* ((bigits (word-bigits x)) + (let* ((bigits (memref scan 0 1 :unsigned-byte14)) (delta (logior bigits 1))) (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (incf scan delta))) @@ -128,27 +120,28 @@ (error "Scanned unknown basic-vector #x~Z at address #x~X." x scan)) ((scavenge-typep x :old-vector) (error "Scanned old-vector ~Z at address #x~X." x scan)) - ((eq x (%lispval-object 3)) + ((eq x 3) (incf scan) (let ((delta (memref scan 0 0 :lisp))) (check-type delta positive-fixnum) ;; (warn "at ~S skipping ~S to ~S." scan delta (+ scan delta)) (incf scan delta))) - ((typep x 'pointer) - (let ((new (funcall function x scan))) + (t ;; (typep x 'pointer) + (let* ((old (memref scan 0 0 :lisp)) + (new (funcall function old scan))) (when verbose - (format *terminal-io* " [~Z => ~Z]" x new)) - (unless (eq new x) + (format *terminal-io* " [~Z => ~Z]" old new)) + (unless (eq old new) (setf (memref scan 0 0 :lisp) new)))))))) (values)) -(defun map-stack-words (function start-stack-frame) +(defun map-stack-words (function stack start-frame) "Map function over the potential pointer words of a stack, starting at the start-stack-frame location." - (loop for nether-frame = start-stack-frame then frame - and frame = (stack-frame-uplink start-stack-frame) then (stack-frame-uplink frame) + (loop for nether-frame = start-frame then frame + and frame = (stack-frame-uplink stack start-frame) then (stack-frame-uplink stack frame) while (plusp frame) - do (let ((funobj (funcall function (stack-frame-funobj frame t) nil))) + do (let ((funobj (funcall function (stack-frame-funobj stack frame) nil))) (typecase funobj (function (assert (= 0 (funobj-frame-num-unboxed funobj))) @@ -160,103 +153,108 @@ (cond ((logbitp 10 (dit-frame-ref :eflags :unsigned-byte32 0 dit-frame)) ;; DF flag was 1, so EAX and EDX are not GC roots. + #+ignore (warn "Interrupt in uncommon mode at ~S" (dit-frame-ref :eip :unsigned-byte32 0 dit-frame)) (map-heap-words function ; Assume nothing in the dit-frame above the location .. (+ nether-frame 2) ; ..of EBX holds pointers. (+ frame (dit-frame-index :ebx)))) - (t (warn "Interrupt in COMMON mode!") + (t #+ignore + (warn "Interrupt in COMMON mode!") (map-heap-words function ; Assume nothing in the dit-frame above the location .. (+ nether-frame 2) ; ..of ECX holds pointers. (+ frame (dit-frame-index :ecx))))) ;; 2. Pop to (dit-)frame's CASF (setf nether-frame frame frame (dit-frame-casf frame)) - (let ((casf-funobj (funcall function (stack-frame-funobj frame t) nil)) + (let ((casf-funobj (funcall function (stack-frame-funobj stack frame) nil)) (interrupted-esp (dit-frame-esp dit-frame))) - (assert (typep casf-funobj 'function) () - "Interrupted CASF frame was not a normal function: ~S" - casf-funobj) - (let ((casf-code-vector (funobj-code-vector casf-funobj))) - ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii. - (cond - ((location-in-object-p casf-code-vector - (dit-frame-ref :eip :location 0 dit-frame)) - ;; Situation i. Nothing special on stack, scavenge frame normally. - (map-heap-words function interrupted-esp frame)) - ((eq casf-frame (memref interrupted-esp 0 0 :location)) - ;; Situation ii. esp(0)=CASF, esp(1)=code-vector - (assert (location-in-object-p casf-code-vector - (memref interrupted-esp 0 1 :location)) - () "Stack discipline situation ii. invariant broken. CASF=#x~X" - casf-frame) - (map-heap-words function (+ interrupted-esp 2) frame)) - (t ;; Situation iii. esp(0)=code-vector. - (assert (location-in-object-p casf-code-vector - (memref interrupted-esp 0 0 :location)) - () "Stack discipline situation iii. invariant broken. CASF=#x~X" - casf-frame) - (map-heap-words function (+ interrupted-esp 1) frame))))))) + (cond + ((eq 0 casf-funobj) + (warn "Interrupt (presumably) in interrupt trampoline.")) + (t (assert (typep casf-funobj 'function) () + "Interrupted CASF frame was not a normal function: ~S" + casf-funobj) + (let ((casf-code-vector (funobj-code-vector casf-funobj))) + ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii. + (cond + ((location-in-object-p casf-code-vector + (dit-frame-ref :eip :location 0 dit-frame)) + ;; Situation i. Nothing special on stack, scavenge frame normally. + (map-heap-words function interrupted-esp frame)) + ((eq casf-frame (memref interrupted-esp 0 0 :location)) + ;; Situation ii. esp(0)=CASF, esp(1)=code-vector + (assert (location-in-object-p casf-code-vector + (memref interrupted-esp 0 1 :location)) + () "Stack discipline situation ii. invariant broken. CASF=#x~X" + casf-frame) + (map-heap-words function (+ interrupted-esp 2) frame)) + (t ;; Situation iii. esp(0)=code-vector. + (assert (location-in-object-p casf-code-vector + (memref interrupted-esp 0 0 :location)) + () "Stack discipline situation iii. invariant broken. CASF=#x~X" + casf-frame) + (map-heap-words function (+ interrupted-esp 1) frame))))))))) (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj))))) (values)) -(defparameter *primitive-funcall-patterns* - '((:or - (#xff #x57 (:function-offset :signed8)) ; - (#xff #x97 (:function-offset :signed32))))) ; - -(defun stack-frame-primitive-funcall (funobj stack-location eip-location) - "Is stack-frame in a primitive-function? -If so, return the primitive-function's code-vector." - (declare (ignore eip-location)) - ;; XXXX Really we should make comparisons against :call-local-pf - ;; such that we find the active set of local-pf's from the stack-location! - (let ((return-address (memref stack-location 0 0 :unsigned-byte32)) - (code-vector (funobj-code-vector funobj))) - (multiple-value-bind (return-location return-delta) - (truncate return-address #.movitz:+movitz-fixnum-factor+) - (if (not (location-in-object-p code-vector return-location)) - nil ; A PF must have return-address on top of stack. - (dotimes (offset 5 (warn "mismatch in ~S at ~D from #x~X in ~Z." - funobj - (+ (* (- return-location - (object-location code-vector)) - #.movitz:+movitz-fixnum-factor+) - return-delta - -3 -8) - return-address code-vector)) - (multiple-value-bind (success-p type code ip) - (match-code-pattern *primitive-funcall-patterns* - code-vector (+ (* (- return-location - (object-location code-vector)) - #.movitz:+movitz-fixnum-factor+) - return-delta - -3 -8 (- offset)) - :function-offset) - (when success-p - (return - (let* ((offset (case type - (:signed8 - (if (not (logbitp 7 code)) code (- code 256))) - (:signed32 - ;; We must read the unsigned-byte32 that starts at ip - (let ((x (logior (aref code-vector (- ip 1)) - (* (aref code-vector (+ 0 ip)) #x100) - (* (aref code-vector (+ 1 ip)) #x10000) - (* (aref code-vector (+ 2 ip)) #x1000000)))) - (if (not (logbitp 7 (aref code-vector (+ ip 2)))) - x - (break "Negative 32-bit offset.")))) - (t (break "Match fail: vec: ~Z, ip: ~D" - code-vector (+ (* (- return-location - (object-location code-vector)) - #.movitz:+movitz-fixnum-factor+) - return-delta - -3 -8))))) - (primitive-function (%word-offset (%run-time-context-ref offset) -2))) - (if (not (typep primitive-function 'code-vector)) - nil - primitive-function)))))))))) +;;;(defparameter *primitive-funcall-patterns* +;;; '((:or +;;; (#xff #x57 (:function-offset :signed8)) ; +;;; (#xff #x97 (:function-offset :signed32))))) ; +;;; +;;;(defun stack-frame-primitive-funcall (funobj stack-location eip-location) +;;; "Is stack-frame in a primitive-function? +;;;If so, return the primitive-function's code-vector." +;;; (declare (ignore eip-location)) +;;; ;; XXXX Really we should make comparisons against :call-local-pf +;;; ;; such that we find the active set of local-pf's from the stack-location! +;;; (let ((return-address (memref stack-location 0 0 :unsigned-byte32)) +;;; (code-vector (funobj-code-vector funobj))) +;;; (multiple-value-bind (return-location return-delta) +;;; (truncate return-address #.movitz:+movitz-fixnum-factor+) +;;; (if (not (location-in-object-p code-vector return-location)) +;;; nil ; A PF must have return-address on top of stack. +;;; (dotimes (offset 5 (warn "mismatch in ~S at ~D from #x~X in ~Z." +;;; funobj +;;; (+ (* (- return-location +;;; (object-location code-vector)) +;;; #.movitz:+movitz-fixnum-factor+) +;;; return-delta +;;; -3 -8) +;;; return-address code-vector)) +;;; (multiple-value-bind (success-p type code ip) +;;; (match-code-pattern *primitive-funcall-patterns* +;;; code-vector (+ (* (- return-location +;;; (object-location code-vector)) +;;; #.movitz:+movitz-fixnum-factor+) +;;; return-delta +;;; -3 -8 (- offset)) +;;; :function-offset) +;;; (when success-p +;;; (return +;;; (let* ((offset (case type +;;; (:signed8 +;;; (if (not (logbitp 7 code)) code (- code 256))) +;;; (:signed32 +;;; ;; We must read the unsigned-byte32 that starts at ip +;;; (let ((x (logior (aref code-vector (- ip 1)) +;;; (* (aref code-vector (+ 0 ip)) #x100) +;;; (* (aref code-vector (+ 1 ip)) #x10000) +;;; (* (aref code-vector (+ 2 ip)) #x1000000)))) +;;; (if (not (logbitp 7 (aref code-vector (+ ip 2)))) +;;; x +;;; (break "Negative 32-bit offset.")))) +;;; (t (break "Match fail: vec: ~Z, ip: ~D" +;;; code-vector (+ (* (- return-location +;;; (object-location code-vector)) +;;; #.movitz:+movitz-fixnum-factor+) +;;; return-delta +;;; -3 -8))))) +;;; (primitive-function (%word-offset (%run-time-context-ref offset) -2))) +;;; (if (not (typep primitive-function 'code-vector)) +;;; nil +;;; primitive-function)))))))))) ;;; (check-type primitive-function code-vector) ;;; (if (not (location-in-object-p primitive-function eip-location)) ;;; nil

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp
by Frode Vatvedt Fjeld 23 Aug '04

23 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6306 Modified Files: inspect.lisp Log Message: Changed the way stack locations are represented: Rather than merely a 'location' (which is a simple pointer, and so GC-unsafe), we now use two values: a vector and an index. If vector is non-nil, index is a an index into the vector. If vector is nil, index is a location (as before), typically referencing the currently active stack, which won't move (but probably this mode should be deprecated). Date: Mon Aug 23 06:58:27 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.34 movitz/losp/muerte/inspect.lisp:1.35 --- movitz/losp/muerte/inspect.lisp:1.34 Thu Jul 29 05:51:40 2004 +++ movitz/losp/muerte/inspect.lisp Mon Aug 23 06:58:25 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.34 2004/07/29 12:51:40 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.35 2004/08/23 13:58:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -38,33 +38,8 @@ (declare (without-check-stack-limit)) ; we do it explicitly.. (check-stack-limit)) -(defun stack-top () - (declare (without-check-stack-limit)) - (load-global-constant stack-top :thread-local t)) - -(defun stack-bottom () - (declare (without-check-stack-limit)) - (load-global-constant stack-bottom :thread-local t)) - -(defun (setf stack-top) (value) - (declare (without-check-stack-limit)) - (check-type value fixnum) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) value) - ((:fs-override) :movl :eax (:edi #.(movitz::global-constant-offset 'stack-top))))) - - -(defun (setf stack-bottom) (value) - (declare (without-check-stack-limit)) - (check-type value fixnum) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) value) - ((:fs-override) :movl :eax (:edi #.(movitz::global-constant-offset 'stack-bottom))))) - - -(defun stack-frame-uplink (stack-frame) - (values (truncate (stack-ref (* 4 stack-frame) 0 0 :unsigned-byte32) - 4))) +(defun stack-frame-uplink (stack frame) + (stack-frame-ref stack frame 0)) (define-compiler-macro current-stack-frame () `(with-inline-assembly (:returns :eax) @@ -72,42 +47,41 @@ :eax))) (defun current-stack-frame () - (stack-frame-uplink (current-stack-frame))) + (stack-frame-uplink nil (current-stack-frame))) -(defun stack-frame-funobj (stack-frame &optional accept-non-funobjs) +(defun stack-frame-funobj (stack frame) + (stack-frame-ref stack frame -1) + #+ignore (when stack-frame - (let ((x (stack-frame-ref stack-frame -1))) + (let ((x (stack-frame-ref stack-frame -1 stack))) (and (or accept-non-funobjs (typep x 'function)) x)))) -(defun stack-frame-call-site (stack-frame) +(defun stack-frame-call-site (stack frame) "Return the code-vector and offset into this vector that is immediately after the point that called this stack-frame." - (let ((funobj (stack-frame-funobj (stack-frame-uplink stack-frame)))) - (when funobj - (let* ((code-vector (funobj-code-vector funobj)) - (x (stack-ref (* 4 stack-frame) 0 1 :unsigned-byte32)) - (delta (- x 8 (* #.movitz::+movitz-fixnum-factor+ (object-location code-vector))))) - (when (below delta (length code-vector)) - (values delta code-vector funobj)))))) - -(defun stack-frame-ref (stack-frame index) - (if (= 0 index) - (stack-frame-uplink stack-frame) - (stack-ref (* 4 stack-frame) 0 index :lisp))) - -(defun stack-ref-p (pointer) - (let ((top (load-global-constant-u32 stack-top)) - (bottom (with-inline-assembly (:returns :eax) - (:movl :esp :eax) - (:shll #.movitz:+movitz-fixnum-shift+ :eax)))) - (<= bottom pointer top))) - -(defun stack-ref (pointer offset index type) - #+ignore (assert (stack-ref-p pointer) (pointer) - "Stack pointer not in range: #x~X" pointer) - (memref-int pointer offset index type)) + (let ((uplink (stack-frame-uplink stack frame))) + (when (and uplink (not (= 0 uplink))) + (let ((funobj (stack-frame-funobj stack uplink))) + (when (typep funobj 'function) + (let* ((code-vector (funobj-code-vector funobj)) + (eip (stack-frame-ref stack frame 1 :unsigned-byte32)) + (delta (- eip 8 (* #.movitz::+movitz-fixnum-factor+ (object-location code-vector))))) + (when (below delta (length code-vector)) + (values delta code-vector funobj)))))))) + +(defun stack-frame-ref (stack frame index &optional (type ':lisp)) + "If stack is provided, stack-frame is an index into that stack vector. +Otherwise, stack-frame is an absolute location." + (cond + ((not (null stack)) + (check-type stack (simple-array (unsigned-byte 32) 1)) + (let ((pos (+ frame index))) + (assert (< -1 pos (length stack)) + () "Index ~S, pos ~S, len ~S" index pos (length stack)) + (memref stack 2 pos type))) + (t (memref frame 0 index type)))) (defun current-dynamic-context () (with-inline-assembly (:returns :untagged-fixnum-ecx) @@ -340,7 +314,7 @@ (* 2 (truncate (+ (structure-object-length object) 1) 2)))))))) -(defun copy-control-stack (&key (absolutep) +(defun copy-control-stack (&key (relative-uplinks t) (stack (%run-time-context-slot 'stack-vector)) (frame (current-stack-frame))) (assert (location-in-object-p stack frame)) @@ -359,9 +333,13 @@ (assert (< -1 uplink-index (length copy)) () "Uplink-index outside copy: ~S, i: ~S" uplink-index i) (setf (svref%unsafe copy i) - (if absolutep + (if relative-uplinks uplink-index (let ((x (+ uplink-index copy-start-location))) - (assert (location-in-object-p copy x)) - (setf (svref%unsafe copy i) x)))) + (assert (= copy-start-location (+ 2 (object-location copy))) () + "Destination stack re-located!") + (assert (location-in-object-p copy x) () + "Bad uplink ~S computed from index ~S and copy ~Z, csl: ~S" + x uplink-index copy copy-start-location) + x))) (setf i uplink-index))))))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp
by Frode Vatvedt Fjeld 23 Aug '04

23 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4258 Modified Files: conditions.lisp Log Message: Changed the way stack locations are represented: Rather than merely a 'location' (which is a simple pointer, and so GC-unsafe), we now use two values: a vector and an index. If vector is non-nil, index is a an index into the vector. If vector is nil, index is a location (as before), typically referencing the currently active stack, which won't move (but probably this mode should be deprecated). Date: Mon Aug 23 06:58:19 2004 Author: ffjeld Index: movitz/losp/muerte/conditions.lisp diff -u movitz/losp/muerte/conditions.lisp:1.11 movitz/losp/muerte/conditions.lisp:1.12 --- movitz/losp/muerte/conditions.lisp:1.11 Fri Jul 23 08:35:45 2004 +++ movitz/losp/muerte/conditions.lisp Mon Aug 23 06:58:19 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.11 2004/07/23 15:35:45 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.12 2004/08/23 13:58:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -285,7 +285,7 @@ (format t "~%Condition for debugger: ~Z" condition) (format t "~%No abort restart is active. Halting CPU.") (halt-cpu)))) - (t (let ((*debugger-invoked-stack-frame* (stack-frame-uplink (current-stack-frame)))) + (t (let ((*debugger-invoked-stack-frame* (stack-frame-uplink nil (current-stack-frame)))) (funcall *debugger-function* condition)))) (format *debug-io* "~&Debugger ~@[on ~S ]returned!~%Trying to abort...~%" condition) (let ((r (find-restart 'abort)))

1 0

[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp
by Frode Vatvedt Fjeld 23 Aug '04

23 Aug '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv1376 Modified Files: los0-gc.lisp Log Message: Changed the way stack locations are represented: Rather than merely a 'location' (which is a simple pointer, and so GC-unsafe), we now use two values: a vector and an index. If vector is non-nil, index is a an index into the vector. If vector is nil, index is a location (as before), typically referencing the currently active stack, which won't move (but probably this mode should be deprecated). Date: Mon Aug 23 06:58:07 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.33 movitz/losp/los0-gc.lisp:1.34 --- movitz/losp/los0-gc.lisp:1.33 Tue Jul 27 06:53:33 2004 +++ movitz/losp/los0-gc.lisp Mon Aug 23 06:58:07 2004 @@ -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.33 2004/07/27 13:53:33 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.34 2004/08/23 13:58:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -368,7 +368,7 @@ nil x))) (map-heap-words #'zap-oldspace 0 (malloc-end)) - (map-stack-words #'zap-oldspace (current-stack-frame)) + (map-stack-words #'zap-oldspace nil (current-stack-frame)) (initialize-space oldspace) (values)))) @@ -377,92 +377,95 @@ (defun stop-and-copy (&optional evacuator) (setf (fill-pointer *x*) 0) - (let* ((space0 (%run-time-context-slot 'nursery-space)) - (space1 (space-other space0))) - (check-type space0 vector-u32) - (check-type space1 vector-u32) - (assert (eq space0 (space-other space1))) - (multiple-value-bind (newspace oldspace) - (if (< (space-fresh-pointer space0) ; Chose the emptiest space as newspace. - (space-fresh-pointer space1)) - (values space0 space1) - (values space1 space0)) - ;; Ensure newspace is activated. - (setf (%run-time-context-slot 'nursery-space) newspace) - ;; Evacuate-oldspace is to be mapped over every potential pointer. - (let ((evacuator - (or evacuator - (lambda (x location) - "If x is in oldspace, migrate it to newspace." - (declare (ignore location)) - (cond - ((not (object-in-space-p oldspace x)) - x) - (t (let ((forwarded-x (memref (object-location x) 0 0 :lisp))) - (if (object-in-space-p newspace forwarded-x) - (progn - (assert (eq (object-tag forwarded-x) - (object-tag 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)) - ;; Scavenge roots - (dolist (range muerte::%memory-map-roots%) - (map-heap-words evacuator (car range) (cdr range))) - (map-stack-words evacuator (current-stack-frame)) - ;; 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-heap-words evacuator - (+ newspace-location scan-pointer) - (+ newspace-location (space-fresh-pointer newspace))) - (setf scan-pointer fresh-pointer)) - - ;; Consistency check.. - (when *gc-consitency-check* - (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 0 :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.") - (error "GC consistency check failed: + (multiple-value-bind (newspace oldspace) + (without-interrupts + (let* ((space0 (%run-time-context-slot 'nursery-space)) + (space1 (space-other space0))) + (check-type space0 vector-u32) + (check-type space1 vector-u32) + (assert (eq space0 (space-other space1))) + (multiple-value-bind (newspace oldspace) + (if (< (space-fresh-pointer space0) ; Chose the emptiest space as newspace. + (space-fresh-pointer space1)) + (values space0 space1) + (values space1 space0)) + ;; Ensure newspace is activated. + (setf (%run-time-context-slot 'nursery-space) newspace) + (values newspace oldspace)))) + ;; Evacuate-oldspace is to be mapped over every potential pointer. + (let ((evacuator + (or evacuator + (lambda (x location) + "If x is in oldspace, migrate it to newspace." + (declare (ignore location)) + (cond + ((not (object-in-space-p oldspace x)) + x) + (t (let ((forwarded-x (memref (object-location x) 0 0 :lisp))) + (if (object-in-space-p newspace forwarded-x) + (progn + (assert (eq (object-tag forwarded-x) + (object-tag 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)) + ;; Scavenge roots + (dolist (range muerte::%memory-map-roots%) + (map-heap-words evacuator (car range) (cdr range))) + (map-stack-words evacuator nil (current-stack-frame)) + ;; 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-heap-words evacuator + (+ newspace-location scan-pointer) + (+ newspace-location (space-fresh-pointer newspace))) + (setf scan-pointer fresh-pointer)) + + ;; Consistency check.. + (when *gc-consitency-check* + (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 0 :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.") + (error "GC consistency check failed: old object: ~Z: ~S new object: ~Z: ~S oldspace: ~Z, newspace: ~Z, i: ~D" - old old new new oldspace newspace i)))))))) + old old new new oldspace newspace i)))))))) - ;; GC completed, oldspace is evacuated. - (unless *gc-quiet* - (let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2)) - (new-size (truncate (- (space-fresh-pointer newspace) 2) 2))) - (format t "Old space: ~/muerte:pprint-clumps/, new space: ~ + ;; GC completed, oldspace is evacuated. + (unless *gc-quiet* + (let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2)) + (new-size (truncate (- (space-fresh-pointer newspace) 2) 2))) + (format t "Old space: ~/muerte:pprint-clumps/, new space: ~ ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%" - old-size new-size (- old-size new-size)))) - (initialize-space oldspace) - (fill oldspace #x13 :start 2)))) + old-size new-size (- old-size new-size)))) + (initialize-space oldspace) + #+ignore (fill oldspace #x13 :start 2))) (values))

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/ne2k.lisp
by Frode Vatvedt Fjeld 23 Aug '04

23 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv27586 Modified Files: ne2k.lisp Log Message: Made the ne2000 prober slightly less picky about the state of the dp8390 registers, so that it'll find the QEMU ne2k device. Date: Mon Aug 23 06:53:38 2004 Author: ffjeld Index: movitz/losp/x86-pc/ne2k.lisp diff -u movitz/losp/x86-pc/ne2k.lisp:1.10 movitz/losp/x86-pc/ne2k.lisp:1.11 --- movitz/losp/x86-pc/ne2k.lisp:1.10 Wed Jul 21 17:58:56 2004 +++ movitz/losp/x86-pc/ne2k.lisp Mon Aug 23 06:53:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 17 15:16:00 2002 ;;;; -;;;; $Id: ne2k.lisp,v 1.10 2004/07/22 00:58:56 ffjeld Exp $ +;;;; $Id: ne2k.lisp,v 1.11 2004/08/23 13:53:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -53,8 +53,8 @@ (io-delay 5000) (setf (dp8390 #x1f) tmp)) (cond - ((not (and (= (logand #b00111111 (dp8390 ($page0-read cr))) - ($command stop abort-complete)) + ((not (and #+ignore (= (logand #b00111111 (dp8390 ($page0-read cr))) + ($command stop abort-complete)) (eq 'ne2000 (ne-x000-probe io-base)))) (format t "failed.~%")) (t (let ((device (make-ne2000 io-base)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp
by Frode Vatvedt Fjeld 23 Aug '04

23 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv32256 Modified Files: primitive-functions.lisp Log Message: When setting up a 'fake' stack-frame in a PF, don't use ESI as the funobj. Not really sure what to /do/ use, yet.. Date: Mon Aug 23 06:51:57 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.39 movitz/losp/muerte/primitive-functions.lisp:1.40 --- movitz/losp/muerte/primitive-functions.lisp:1.39 Sat Aug 7 04:12:09 2004 +++ movitz/losp/muerte/primitive-functions.lisp Mon Aug 23 06:51:57 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.39 2004/08/07 11:12:09 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.40 2004/08/23 13:51:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -122,7 +122,7 @@ (with-inline-assembly (:returns :push) (:pushl :ebp) (:movl :esp :ebp) ; set up a pseudo stack-frame - (:pushl :esi) ; for consistency + (:pushl 4) (:globally (:movl (:edi (:edi-offset unwind-protect-tag)) :edx)) (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs