From ffjeld at common-lisp.net Tue Feb 1 16:20:09 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 1 Feb 2005 08:20:09 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: <20050201162009.8B75088029@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1611 Modified Files: primitive-functions.lisp Log Message: Minor edit. Date: Tue Feb 1 08:20:08 2005 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.61 movitz/losp/muerte/primitive-functions.lisp:1.62 --- movitz/losp/muerte/primitive-functions.lisp:1.61 Tue Jan 25 05:54:57 2005 +++ movitz/losp/muerte/primitive-functions.lisp Tue Feb 1 08:20:08 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.61 2005/01/25 13:54:57 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.62 2005/02/01 16:20:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -73,7 +73,8 @@ (with-inline-assembly (:returns :nothing) (:movl :esi :edx) ; parameter for standard-gf-function. (:movl (:esi ,(bt:slot-offset 'movitz::movitz-funobj-standard-gf - (intern (symbol-name to) :movitz))) :esi) + (intern (symbol-name to) :movitz))) + :esi) (:jmp (:esi ,(bt:slot-offset 'movitz::movitz-funobj (intern (symbol-name forward) :movitz))))))) From ffjeld at common-lisp.net Wed Feb 2 07:47:35 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 2 Feb 2005 08:47:35 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp Message-ID: <20050202074735.9BB888802C@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19046 Modified Files: memref.lisp Log Message: Completed (setf memref :code-vector). Date: Wed Feb 2 08:47:34 2005 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.42 movitz/losp/muerte/memref.lisp:1.43 --- movitz/losp/muerte/memref.lisp:1.42 Tue Jan 25 14:51:36 2005 +++ movitz/losp/muerte/memref.lisp Wed Feb 2 08:47:34 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.42 2005/01/25 13:51:36 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.43 2005/02/02 07:47:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -774,11 +774,10 @@ (:ebx :ecx ,(movitz:movitz-eval offset env))) (,prefixes :addl :eax (:ebx :ecx ,(movitz:movitz-eval offset env))))))) - (t (error "variable (setf memref) type :code-vector not implemented.") - #+ignore - (let ((value-var (gensym "memref-value-")) + (t (let ((value-var (gensym "memref-value-")) (object-var (gensym "memref-object-"))) - `(let ((,value-var ,value) (,object-var ,object)) + `(let ((,value-var ,value) + (,object-var ,object)) (with-inline-assembly (:returns :eax) (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,offset ,index) (:load-lexical (:lexical-binding ,value-var) :eax) @@ -786,7 +785,8 @@ `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx)) (:addl :ebx :ecx) ; index += offset (:load-lexical (:lexical-binding ,object-var) :ebx) - (:movl :eax (:ebx :ecx))))))))) + (:movl ,movitz:+code-vector-word-offset+ (:ebx :ecx)) + (,prefixes :addl :eax (:ebx :ecx))))))))) (t ;; (warn "Can't handle inline MEMREF: ~S" form) form)))) @@ -812,7 +812,11 @@ (:lisp (if localp (setf (memref object offset :index index :localp t) value) - (setf (memref object offset :index index :localp nil) value))))) + (setf (memref object offset :index index :localp nil) value))) + (:code-vector + (if localp + (setf (memref object offset :index index :localp t :type :code-vector) value) + (setf (memref object offset :index index :localp nil :type :code-vector) value))))) (define-compiler-macro memref-int (&whole form address &key (offset 0) (index 0) (type :unsigned-byte32) (physicalp t) From ffjeld at common-lisp.net Wed Feb 2 07:48:25 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 2 Feb 2005 08:48:25 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/bootblock.lisp Message-ID: <20050202074825.40F6F8802C@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv19078 Modified Files: bootblock.lisp Log Message: Minor edits: use keyword assembly instructions. Date: Wed Feb 2 08:48:21 2005 Author: ffjeld Index: movitz/bootblock.lisp diff -u movitz/bootblock.lisp:1.10 movitz/bootblock.lisp:1.11 --- movitz/bootblock.lisp:1.10 Wed Jul 7 19:33:04 2004 +++ movitz/bootblock.lisp Wed Feb 2 08:48:21 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001,2000, 2002-2004, +;;;; Copyright (C) 2001,2000, 2002-2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: bootblock.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Mon Oct 9 20:47:19 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: bootblock.lisp,v 1.10 2004/07/07 17:33:04 ffjeld Exp $ +;;;; $Id: bootblock.lisp,v 1.11 2005/02/02 07:48:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -35,32 +35,32 @@ (defun mkasm16-bios-print () "Print something to the terminal. [es:si] points to the text" - `((movzxb (:si) :cx) - (incw :si) - (movb #xe :ah) - (movw 7 :bx) - :print-loop - (lodsb) - (int #x10) - (loop ':print-loop) - (ret))) + `((:movzxb (:si) :cx) + (:incw :si) + (:movb #xe :ah) + (:movw 7 :bx) + print-loop + (:lodsb) + (:int #x10) + (:loop 'print-loop) + (:ret))) (defun mkasm16-format-hex () "Format a 16-bit word (in DX) into hex string (in DI)" - `((std) - (movw 4 :cx) - (addw :cx :di) - (decw :di) - :format-loop - (movb :dl :bl) - (andw #x0f bx) - (movb ('hex-table bx) :al) - (stosb) - (shrw :dx 4) - (decw :cx) - (jnz ':format-loop) - (cld) - (ret) + `((:std) + (:movw 4 :cx) + (:addw :cx :di) + (:decw :di) + format-loop + (:movb :dl :bl) + (:andw #x0f bx) + (:movb ('hex-table bx) :al) + (:stosb) + (:shrw :dx 4) + (:decw :cx) + (:jnz 'format-loop) + (:cld) + (:ret) hex-table (% format nil "0123456789abcdef"))) (defconstant +SECTOR-SIZE+ 512) From ffjeld at common-lisp.net Wed Feb 2 07:49:02 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 2 Feb 2005 08:49:02 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20050202074902.DCE8E8802C@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv19097 Modified Files: compiler.lisp Log Message: Teach make-compiled-stack-restore about :untagged-fixnum-ecx. Date: Wed Feb 2 08:49:00 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.133 movitz/compiler.lisp:1.134 --- movitz/compiler.lisp:1.133 Mon Jan 31 15:11:14 2005 +++ movitz/compiler.lisp Wed Feb 2 08:48:58 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.133 2005/01/31 14:11:14 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.134 2005/02/02 07:48:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5369,7 +5369,7 @@ ((:single-value :eax :ebx) (values `((:addl ,(* 4 stack-displacement) :esp)) :multiple-values)))) ; assume this addl will set CF=0 - ((:single-value :eax :ebx :ecx :edx :push :lexical-binding + ((:single-value :eax :ebx :ecx :edx :push :lexical-binding :untagged-fixnum-ecx :boolean :boolean-branch-on-false :boolean-branch-on-true) (ecase returns (#.+boolean-modes+ From ffjeld at common-lisp.net Wed Feb 2 07:50:26 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 2 Feb 2005 08:50:26 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: <20050202075026.97EFD8802C@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19119 Modified Files: interrupt.lisp Log Message: Fixed DIT's restarting of atomically-continuations. Date: Wed Feb 2 08:50:25 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.37 movitz/losp/muerte/interrupt.lisp:1.38 --- movitz/losp/muerte/interrupt.lisp:1.37 Fri Jan 28 09:49:07 2005 +++ movitz/losp/muerte/interrupt.lisp Wed Feb 2 08:50:25 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.37 2005/01/28 08:49:07 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.38 2005/02/02 07:50:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -141,12 +141,12 @@ (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) ;; Do RET atomicification - (:movl (:ebp ,(dit-frame-offset :eip)) :ecx) - ((:cs-override) :cmpb ,(realpart (ia-x86:asm :ret)) (:ecx)) - (:jne 'not-at-ret-instruction) - (:globally (:movl (:edi (:edi-offset ret-trampoline)) :ecx)) - (:movl :ecx (:ebp ,(dit-frame-offset :eip))) - not-at-ret-instruction +;;; (:movl (:ebp ,(dit-frame-offset :eip)) :ecx) +;;; ((:cs-override) :cmpb ,(realpart (ia-x86:asm :ret)) (:ecx)) +;;; (:jne 'not-at-ret-instruction) +;;; (:globally (:movl (:edi (:edi-offset ret-trampoline)) :ecx)) +;;; (:movl :ecx (:ebp ,(dit-frame-offset :eip))) +;;; not-at-ret-instruction (:xorl :eax :eax) ; Ensure safe value (:xorl :edx :edx) ; Ensure safe value @@ -251,14 +251,16 @@ (:jnz 'restart-simple-pf) ;; ECX is a throw target aka. next continuation step. - (:locally (:movl :esi (:edi (:edi-offset scratch1)))) + + (:movl :edi :esi) ; before bumping ESP, remove reference to funobj.. + ; ..in case it's stack-allocated. (:movl (:ecx 12) :edx) (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; exit to target dynamic-env - (:movl :ecx :esp) ; enter non-local jump stack mode. + (:movl :edi :ebp) ; enter non-local jump stack mode. + (:movl :ecx :esp) ; (:movl (:esp) :ecx) ; target stack-frame EBP (:movl (:ecx -4) :esi) ; get target funobj into ESI - (:movl (:esp 8) :ecx) ; target jumper number (:jmp (:esi :ecx (:offset movitz-funobj constant0))) From ffjeld at common-lisp.net Wed Feb 2 07:50:59 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 2 Feb 2005 08:50:59 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: <20050202075059.AD8298802C@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19141 Modified Files: scavenge.lisp Log Message: Fixed a number of stack-scavenging bugs. Date: Wed Feb 2 08:50:57 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.45 movitz/losp/muerte/scavenge.lisp:1.46 --- movitz/losp/muerte/scavenge.lisp:1.45 Mon Jan 31 18:54:03 2005 +++ movitz/losp/muerte/scavenge.lisp Wed Feb 2 08:50:57 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.45 2005/01/31 17:54:03 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.46 2005/02/02 07:50:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -175,7 +175,7 @@ (when (location-in-object-p code-vector location) (return code-vector)))))) -(defun scavenge-find-code-vector (location casf-funobj esi &optional primitive-function-p) +(defun scavenge-find-code-vector (location casf-funobj esi &optional primitive-function-p edx) (flet ((match-funobj (funobj location) (cond ((not (typep funobj 'function)) @@ -203,7 +203,9 @@ ((match-funobj esi location)) (t (break "DIT returns outside DIT??"))))) ((match-funobj casf-funobj location)) - ((match-funobj esi location)) + ((match-funobj esi location)) + ((match-funobj edx location) + (break "Trampoline/EDX situation?")) ((not (typep casf-funobj 'function)) (break "Unknown funobj/frame-type: ~S" casf-funobj)) ((location-in-object-p (%run-time-context-slot 'dynamic-jump-next) location) @@ -302,7 +304,7 @@ 0 interrupted-esi nil)) (new-code-vector (map-stack-instruction-pointer function eip-index old-code-vector))) - ;; + ;; (when atomically (we should be more clever about the stack..)) (multiple-value-bind (x0-location x0-tag) (stack-frame-ref nil next-frame-bottom 0 :signed-byte30+2) (cond @@ -316,7 +318,9 @@ (symbol-value 'ret-trampoline))) (let* ((old-x0-code-vector (scavenge-find-code-vector (stack-frame-ref nil next-eip-index 0 :location) - casf-funobj interrupted-esi t))) + casf-funobj interrupted-esi t + (unless secondary-register-mode-p + (dit-frame-ref nil dit-frame :edx))))) (map-stack-instruction-pointer function next-eip-index old-x0-code-vector)) (setf next-eip-index next-frame-bottom next-frame-bottom (1+ next-frame-bottom))) @@ -328,7 +332,10 @@ (location-in-object-p casf-code-vector x1-location)) (let* ((old-x1-code-vector (scavenge-find-code-vector (stack-frame-ref nil next-eip-index 0 :location) - casf-funobj interrupted-esi t))) + casf-funobj + (unless secondary-register-mode-p + interrupted-esi) + t))) (map-stack-instruction-pointer function next-eip-index old-x1-code-vector)) (setf next-eip-index (+ 1 next-frame-bottom) next-frame-bottom (+ 2 next-frame-bottom))))))) From ffjeld at common-lisp.net Wed Feb 2 07:51:27 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 2 Feb 2005 08:51:27 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: <20050202075127.1AC948802C@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv19160 Modified Files: debugger.lisp Log Message: Tweaked stack-frame-numargs to be slightly more clever. Date: Wed Feb 2 08:51:26 2005 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.30 movitz/losp/x86-pc/debugger.lisp:1.31 --- movitz/losp/x86-pc/debugger.lisp:1.30 Thu Jan 27 12:19:53 2005 +++ movitz/losp/x86-pc/debugger.lisp Wed Feb 2 08:51:26 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.30 2005/01/27 11:19:53 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.31 2005/02/02 07:51:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -144,12 +144,17 @@ ((integerp (car map)) (car map)) ((eq :ecx (car map)) - (cond - ((= #xb1 (aref code (- call-site 5))) - ;; Assume it's a (:movb x :cl) instruction - (aref code (- call-site 4))) - (t ;; now we should search further for where ecx may be set.. - nil))))))))))) + (let ((load-ecx-index (- call-site 4))) + (loop while (and (plusp load-ecx-index) + (= #x90 (aref code load-ecx-index))) ; Skip any NOPs + do (decf load-ecx-index)) + (cond + ((= #xb1 (aref code (- load-ecx-index 1))) + ;; Assume it's a (:movb x :cl) instruction + (aref code load-ecx-index)) + (t ;; now we should search further for where ecx may be set.. + (format t "{no ECX at ~D in ~S}" call-site funobj) + nil)))))))))))) (defun signed8-index (s8) "Convert a 8-bit twos-complement signed integer bitpattern to From ffjeld at common-lisp.net Wed Feb 2 09:12:55 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 2 Feb 2005 10:12:55 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp Message-ID: <20050202091255.193E48802C@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23031 Modified Files: inspect.lisp Log Message: Teach stack-frame-call-site about DIT-frames. Date: Wed Feb 2 10:12:54 2005 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.46 movitz/losp/muerte/inspect.lisp:1.47 --- movitz/losp/muerte/inspect.lisp:1.46 Tue Jan 25 14:49:51 2005 +++ movitz/losp/muerte/inspect.lisp Wed Feb 2 10:12:54 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.46 2005/01/25 13:49:51 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.47 2005/02/02 09:12:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -70,12 +70,19 @@ (let ((uplink (stack-frame-uplink stack frame))) (when (and uplink (not (= 0 uplink))) (let ((funobj (stack-frame-funobj stack uplink))) - (when (typep funobj 'function) + (cond + ((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)))))))) + (values delta code-vector funobj)))) + ((eq 0 funobj) + (let* ((code-vector (symbol-value 'default-interrupt-trampoline)) + (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. From ffjeld at common-lisp.net Wed Feb 2 10:23:08 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 2 Feb 2005 11:23:08 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: <20050202102308.14FE18864B@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv27130 Modified Files: debugger.lisp Log Message: Improved stack-frame-numargs to recognize (:xorl :ecx :ecx), i.e. the passing of zero arguments to a frame. Date: Wed Feb 2 11:23:07 2005 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.31 movitz/losp/x86-pc/debugger.lisp:1.32 --- movitz/losp/x86-pc/debugger.lisp:1.31 Wed Feb 2 08:51:26 2005 +++ movitz/losp/x86-pc/debugger.lisp Wed Feb 2 11:23:07 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.31 2005/02/02 07:51:26 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.32 2005/02/02 10:23:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -148,13 +148,19 @@ (loop while (and (plusp load-ecx-index) (= #x90 (aref code load-ecx-index))) ; Skip any NOPs do (decf load-ecx-index)) - (cond - ((= #xb1 (aref code (- load-ecx-index 1))) - ;; Assume it's a (:movb x :cl) instruction - (aref code load-ecx-index)) - (t ;; now we should search further for where ecx may be set.. - (format t "{no ECX at ~D in ~S}" call-site funobj) - nil)))))))))))) + (let ((opcode0 (aref code (1- load-ecx-index))) + (opcode1 (aref code load-ecx-index))) + (cond + ((= #xb1 opcode0) + ;; Assume it's a (:movb x :cl) instruction + (aref code load-ecx-index)) + ((and (= #x33 opcode0) (= #xc9 opcode1)) + ;; XORL :ECX :ECX + 0) + (t ;; now we should search further for where ecx may be set.. + (format *debug-io* "{no ECX at ~D in ~S, opcode #x~X #x~X}" + call-site funobj opcode0 opcode1) + nil))))))))))))) (defun signed8-index (s8) "Convert a 8-bit twos-complement signed integer bitpattern to From ffjeld at common-lisp.net Wed Feb 2 10:48:50 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 2 Feb 2005 11:48:50 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: <20050202104850.AC1A888655@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv28673 Modified Files: interrupt.lisp Log Message: Changed dit-frame-casf to support atomically mode. Fixed small bug in dit-frame-ref. Date: Wed Feb 2 11:48:49 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.38 movitz/losp/muerte/interrupt.lisp:1.39 --- movitz/losp/muerte/interrupt.lisp:1.38 Wed Feb 2 08:50:25 2005 +++ movitz/losp/muerte/interrupt.lisp Wed Feb 2 11:48:49 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.38 2005/02/02 07:50:25 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.39 2005/02/02 10:48:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -64,7 +64,7 @@ `(memref ,frame (dit-frame-offset ,reg) :type ,type))) (defun dit-frame-ref (stack frame reg &optional (type :lisp)) - (stack-frame-ref stack frame (dit-frame-index reg) type)) + (stack-frame-ref stack (+ frame (dit-frame-index reg)) 0 type)) (define-compiler-macro (setf dit-frame-ref) (&whole form value stack frame reg &optional (type :lisp) @@ -74,14 +74,15 @@ form `(setf (memref ,frame (dit-frame-offset ,reg) :type ,type) ,value))) -;;;(defun (setf dit-frame-ref) (x reg type &optional (frame *last-dit-frame*)) -;;; (setf (memref frame (dit-frame-offset reg) 0 type) x)) - (defun dit-frame-casf (stack dit-frame) "Compute the `currently active stack-frame' when the interrupt occurred." - (let ((ebp (dit-frame-ref stack dit-frame :ebp)) + (let ((atomically-location (dit-frame-ref stack dit-frame :atomically-continuation :location)) + (ebp (dit-frame-ref stack dit-frame :ebp)) (esp (dit-frame-esp stack dit-frame))) (cond + ((and (not (= 0 atomically-location)) + (= 0 (ldb (byte 2 0) (dit-frame-ref stack dit-frame :atomically-continuation :unsigned-byte8)))) + (stack-frame-ref stack atomically-location 0)) ((null ebp) ; special dynamic control-transfer mode (stack-frame-ref stack (dit-frame-ref stack dit-frame :dynamic-env) 0)) ((< esp ebp) From ffjeld at common-lisp.net Thu Feb 3 09:13:20 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 3 Feb 2005 10:13:20 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: <20050203091320.0EE3288660@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2591 Modified Files: scavenge.lisp Log Message: Tweaking of scavenge-find-code-vector: match ret-trampoline, and don't break upon EDX match. Date: Thu Feb 3 10:13:20 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.46 movitz/losp/muerte/scavenge.lisp:1.47 --- movitz/losp/muerte/scavenge.lisp:1.46 Wed Feb 2 08:50:57 2005 +++ movitz/losp/muerte/scavenge.lisp Thu Feb 3 10:13:20 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.46 2005/02/02 07:50:57 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.47 2005/02/03 09:13:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -201,13 +201,16 @@ ((location-in-object-p dit-code-vector location) dit-code-vector) ((match-funobj esi location)) + ((location-in-object-p (symbol-value 'ret-trampoline) location) + (symbol-value 'ret-trampoline)) (t (break "DIT returns outside DIT??"))))) ((match-funobj casf-funobj location)) ((match-funobj esi location)) - ((match-funobj edx location) - (break "Trampoline/EDX situation?")) + ((match-funobj edx location)) ((not (typep casf-funobj 'function)) (break "Unknown funobj/frame-type: ~S" casf-funobj)) + ((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)) ((when primitive-function-p From ffjeld at common-lisp.net Thu Feb 3 09:15:48 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 3 Feb 2005 10:15:48 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cons.lisp Message-ID: <20050203091548.B2F9C8865D@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3307 Modified Files: cons.lisp Log Message: *** empty log message *** Date: Thu Feb 3 10:15:46 2005 Author: ffjeld Index: movitz/losp/muerte/cons.lisp diff -u movitz/losp/muerte/cons.lisp:1.8 movitz/losp/muerte/cons.lisp:1.9 --- movitz/losp/muerte/cons.lisp:1.8 Thu Oct 21 22:33:59 2004 +++ movitz/losp/muerte/cons.lisp Thu Feb 3 10:15:46 2005 @@ -1,15 +1,15 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 20012000, 2002-2004, +;;;; Copyright (C) 2000-2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: cons.lisp -;;;; Description: +;;;; Description: Cons-cell functionality. ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Dec 8 15:25:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: cons.lisp,v 1.8 2004/10/21 20:33:59 ffjeld Exp $ +;;;; $Id: cons.lisp,v 1.9 2005/02/03 09:15:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ From ffjeld at common-lisp.net Thu Feb 3 09:18:45 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 3 Feb 2005 10:18:45 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp Message-ID: <20050203091845.10DBA88660@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv3366 Modified Files: special-operators-cl.lisp Log Message: Changed the protocol (wrt. stack discipline) for dynamic control transfer slightly, so that restart-atomically-continuation (i.e. continue after an interrupt occurred inside an atomical sequence) fits into it all. Date: Thu Feb 3 10:18:45 2005 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.44 movitz/special-operators-cl.lisp:1.45 --- movitz/special-operators-cl.lisp:1.44 Thu Jan 27 09:58:53 2005 +++ movitz/special-operators-cl.lisp Thu Feb 3 10:18:45 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.44 2005/01/27 08:58:53 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.45 2005/02/03 09:18:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -769,7 +769,7 @@ (:locally (:call (:edi (:edi-offset dynamic-unwind-next)))) ;; have next-continuation in EAX, final-continuation in EDX (:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation - + (:locally (:movl :eax (:edi (:edi-offset dynamic-env)))) ; new dynamic-env (:movl :eax :edx) (:clc) (:locally (:call (:edi (:edi-offset dynamic-jump-next)))))))))))) @@ -1304,6 +1304,7 @@ ;;; (:movl ',continue-label (:esp 8)) ; new jumper index (:load-lexical ,next-continuation-step-binding :edx) + (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) (:locally (:call (:edi (:edi-offset dynamic-jump-next)))) ;;; (:locally (:movl :esi (:edi (:edi-offset scratch1)))) From ffjeld at common-lisp.net Thu Feb 3 09:18:53 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 3 Feb 2005 10:18:53 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp Message-ID: <20050203091853.2398988668@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv3383 Modified Files: special-operators.lisp Log Message: Changed the protocol (wrt. stack discipline) for dynamic control transfer slightly, so that restart-atomically-continuation (i.e. continue after an interrupt occurred inside an atomical sequence) fits into it all. Date: Thu Feb 3 10:18:51 2005 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.48 movitz/special-operators.lisp:1.49 --- movitz/special-operators.lisp:1.48 Tue Jan 4 17:54:10 2005 +++ movitz/special-operators.lisp Thu Feb 3 10:18:51 2005 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.48 2005/01/04 16:54:10 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.49 2005/02/03 09:18:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1210,6 +1210,7 @@ `((:load-lexical ,dynamic-slot-binding :edx) (:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation (:load-lexical ,next-continuation-step-binding :edx) ; next continuation-step + (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; goto target dynamic-env (:locally (:call (:edi (:edi-offset dynamic-jump-next)))))))))) ;;; (:locally (:movl :esi (:edi (:edi-offset scratch1)))) From ffjeld at common-lisp.net Thu Feb 3 09:19:00 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 3 Feb 2005 10:19:00 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: <20050203091900.63F0F88664@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3410 Modified Files: interrupt.lisp Log Message: Changed the protocol (wrt. stack discipline) for dynamic control transfer slightly, so that restart-atomically-continuation (i.e. continue after an interrupt occurred inside an atomical sequence) fits into it all. Date: Thu Feb 3 10:18:55 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.39 movitz/losp/muerte/interrupt.lisp:1.40 --- movitz/losp/muerte/interrupt.lisp:1.39 Wed Feb 2 11:48:49 2005 +++ movitz/losp/muerte/interrupt.lisp Thu Feb 3 10:18:55 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.39 2005/02/02 10:48:49 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.40 2005/02/03 09:18:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -84,7 +84,7 @@ (= 0 (ldb (byte 2 0) (dit-frame-ref stack dit-frame :atomically-continuation :unsigned-byte8)))) (stack-frame-ref stack atomically-location 0)) ((null ebp) ; special dynamic control-transfer mode - (stack-frame-ref stack (dit-frame-ref stack dit-frame :dynamic-env) 0)) + (stack-frame-ref stack (dit-frame-ref stack dit-frame :scratch1) 0)) ((< esp ebp) ebp) ((eq esp ebp) @@ -255,15 +255,12 @@ (:movl :edi :esi) ; before bumping ESP, remove reference to funobj.. ; ..in case it's stack-allocated. + (:movl (:ecx 12) :edx) - (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; exit to target dynamic-env - - (:movl :edi :ebp) ; enter non-local jump stack mode. - (:movl :ecx :esp) ; - (:movl (:esp) :ecx) ; target stack-frame EBP - (:movl (:ecx -4) :esi) ; get target funobj into ESI - (:movl (:esp 8) :ecx) ; target jumper number - (:jmp (:esi :ecx (:offset movitz-funobj constant0))) + (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; interruptee's dynamic-env + (:movl :ecx :edx) + (:locally (:call (:edi (:edi-offset dynamic-jump-next)))) + (:int 63) restart-simple-pf ;; ECX holds the run-time-context offset for us to load. From ffjeld at common-lisp.net Thu Feb 3 09:19:09 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 3 Feb 2005 10:19:09 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: <20050203091909.A070188664@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3432 Modified Files: primitive-functions.lisp Log Message: Changed the protocol (wrt. stack discipline) for dynamic control transfer slightly, so that restart-atomically-continuation (i.e. continue after an interrupt occurred inside an atomical sequence) fits into it all. Date: Thu Feb 3 10:19:03 2005 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.62 movitz/losp/muerte/primitive-functions.lisp:1.63 --- movitz/losp/muerte/primitive-functions.lisp:1.62 Tue Feb 1 17:20:08 2005 +++ movitz/losp/muerte/primitive-functions.lisp Thu Feb 3 10:19:02 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.62 2005/02/01 16:20:08 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.63 2005/02/03 09:19:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -685,7 +685,7 @@ (with-inline-assembly (:returns :non-local-exit) (:movl :edi :esi) ; before bumping ESP, remove reference to funobj.. ; ..in case it's stack-allocated. - (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; exit to next-env + (:locally (:movl :edx (:edi (:edi-offset scratch1)))) ; non-local stack-mode target entry. (:movl :edi :ebp) ; enter non-local jump stack mode. (:movl :edx :esp) ; (:movl (:esp) :edx) ; target stack-frame EBP From ffjeld at common-lisp.net Mon Feb 14 07:13:45 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 14 Feb 2005 08:13:45 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/bignums.lisp Message-ID: <20050214071345.B0E52884E1@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18079 Modified Files: bignums.lisp Log Message: In bignum-shift-leftf, ensure that ESI is restored to funobj before the function returns, as mandated by the stack discipline. Date: Mon Feb 14 08:13:42 2005 Author: ffjeld Index: movitz/losp/muerte/bignums.lisp diff -u movitz/losp/muerte/bignums.lisp:1.14 movitz/losp/muerte/bignums.lisp:1.15 --- movitz/losp/muerte/bignums.lisp:1.14 Tue Jan 25 14:45:24 2005 +++ movitz/losp/muerte/bignums.lisp Mon Feb 14 08:13:42 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Jul 17 19:42:57 2004 ;;;; -;;;; $Id: bignums.lisp,v 1.14 2005/01/25 13:45:24 ffjeld Exp $ +;;;; $Id: bignums.lisp,v 1.15 2005/02/14 07:13:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -391,10 +391,10 @@ (:movl :edi :edx) (:movl :edi :eax) ; Safe EAX (:cld) - (:movl (:ebp -4) :esi) shift-short-lsb (:shll :cl (:ebx (:offset movitz-bignum bigit0))) done + (:movl (:ebp -4) :esi) ))) (do-it)))) From ffjeld at common-lisp.net Tue Feb 15 22:22:48 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 15 Feb 2005 23:22:48 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: <20050215222248.A4EF4884E1@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13009 Modified Files: scavenge.lisp Log Message: Rename to map-instruction-pointer. Date: Tue Feb 15 23:22:47 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.47 movitz/losp/muerte/scavenge.lisp:1.48 --- movitz/losp/muerte/scavenge.lisp:1.47 Thu Feb 3 10:13:20 2005 +++ movitz/losp/muerte/scavenge.lisp Tue Feb 15 23:22:47 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.47 2005/02/03 09:13:20 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.48 2005/02/15 22:22:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -98,7 +98,7 @@ (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.") + (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 )) @@ -195,24 +195,22 @@ (location-in-object-p x location) x)))))) (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)) ((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)) - ((location-in-object-p (symbol-value 'ret-trampoline) location) - (symbol-value 'ret-trampoline)) (t (break "DIT returns outside DIT??"))))) ((match-funobj casf-funobj location)) ((match-funobj esi location)) ((match-funobj edx location)) ((not (typep casf-funobj 'function)) (break "Unknown funobj/frame-type: ~S" casf-funobj)) - ((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)) ((when primitive-function-p (scavenge-find-pf location) #+ignore @@ -247,7 +245,7 @@ (t (let* ((old-code-vector (scavenge-find-code-vector (stack-frame-ref nil eip-index 0 :location) frame-funobj nil nil))) - (map-stack-instruction-pointer function eip-index old-code-vector)) + (map-instruction-pointer function eip-index old-code-vector)) (let ((raw-locals (funobj-frame-raw-locals frame-funobj))) (if (= 0 raw-locals) (map-region function frame-bottom frame) @@ -306,7 +304,7 @@ (scavenge-find-code-vector (stack-frame-ref nil eip-index 0 :location) 0 interrupted-esi nil)) - (new-code-vector (map-stack-instruction-pointer function eip-index old-code-vector))) + (new-code-vector (map-instruction-pointer function eip-index old-code-vector))) ;; (when atomically (we should be more clever about the stack..)) (multiple-value-bind (x0-location x0-tag) (stack-frame-ref nil next-frame-bottom 0 :signed-byte30+2) @@ -324,7 +322,7 @@ casf-funobj interrupted-esi t (unless secondary-register-mode-p (dit-frame-ref nil dit-frame :edx))))) - (map-stack-instruction-pointer function next-eip-index old-x0-code-vector)) + (map-instruction-pointer function next-eip-index old-x0-code-vector)) (setf next-eip-index next-frame-bottom next-frame-bottom (1+ next-frame-bottom))) (t (multiple-value-bind (x1-location x1-tag) @@ -339,19 +337,21 @@ (unless secondary-register-mode-p interrupted-esi) t))) - (map-stack-instruction-pointer function next-eip-index old-x1-code-vector)) + (map-instruction-pointer function next-eip-index old-x1-code-vector)) (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-stack-instruction-pointer (function index old-code-vector) - "Update the (raw) instruction-pointer in stack at index, +(defun map-instruction-pointer (function location + &optional (old-code-vector (memref location 0 :type :code-vector))) + "Update the (raw) instruction-pointer at location, assuming the pointer refers to old-code-vector." - (assert (location-in-object-p old-code-vector (stack-frame-ref nil index 0 :location))) + (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. [index: ~S]" index)) + (break "Code-vector for stack instruction-pointer moved at location ~S" location)) new-code-vector)) From ffjeld at common-lisp.net Thu Feb 24 12:21:32 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 24 Feb 2005 13:21:32 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/lib/repl.lisp Message-ID: <20050224122132.5BEAD8866B@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv9149 Modified Files: repl.lisp Log Message: Have the REPL interpret integers as restart to be invoked. Date: Thu Feb 24 13:21:31 2005 Author: ffjeld Index: movitz/losp/lib/repl.lisp diff -u movitz/losp/lib/repl.lisp:1.13 movitz/losp/lib/repl.lisp:1.14 --- movitz/losp/lib/repl.lisp:1.13 Sat Sep 25 17:25:53 2004 +++ movitz/losp/lib/repl.lisp Thu Feb 24 13:21:30 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 ;;;; Created at: Wed Mar 19 14:58:12 2003 ;;;; -;;;; $Id: repl.lisp,v 1.13 2004/09/25 15:25:53 ffjeld Exp $ +;;;; $Id: repl.lisp,v 1.14 2005/02/24 12:21:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -82,20 +82,26 @@ nil (copy-list results))) (values-list results))) - (if (not (keywordp form)) + (let ((restart (and (integerp form) + (muerte:find-restart-by-index form + muerte:*debugger-dynamic-context*)))) + (cond + (restart + (invoke-restart-interactively restart)) + ((not (keywordp form)) (multiple-value-call #'process-expresion - form previous-package t (eval form)) - (multiple-value-call #'process-expresion - form previous-package nil - (apply 'muerte.toplevel:invoke-toplevel-command - form - (loop for arg = (multiple-value-bind (arg x) - (simple-read-from-string buffer-string nil '#0=#:eof - :start buffer-pointer) - (setq buffer-pointer x) - arg) - until (eq arg '#0#) - collect arg)))))))) + form previous-package t (eval form))) + (t (multiple-value-call #'process-expresion + form previous-package nil + (apply 'muerte.toplevel:invoke-toplevel-command + form + (loop for arg = (multiple-value-bind (arg x) + (simple-read-from-string buffer-string nil '#0=#:eof + :start buffer-pointer) + (setq buffer-pointer x) + arg) + until (eq arg '#0#) + collect arg)))))))))) (muerte.readline::readline-break (c) (declare (ignore c)) (values)))) From ffjeld at common-lisp.net Thu Feb 24 12:23:09 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 24 Feb 2005 13:23:09 +0100 (CET) Subject: [movitz-cvs] CVS update: public_html/ChangeLog Message-ID: <20050224122309.0B66F8866B@common-lisp.net> Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv9175 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Thu Feb 24 13:23:08 2005 Author: ffjeld Index: public_html/ChangeLog diff -u public_html/ChangeLog:1.1 public_html/ChangeLog:1.2 --- public_html/ChangeLog:1.1 Sat Jan 29 11:42:28 2005 +++ public_html/ChangeLog Thu Feb 24 13:23:08 2005 @@ -1,3 +1,8 @@ +2005-02-24 Frode Vatvedt Fjeld + + * Entering an integer at the REPL now invokes the corresponding + restart, if it exists. + 2005-01-29 Frode Vatvedt Fjeld * There's been quite a bit of work on scavenge.lisp. The stack scavenging From ffjeld at common-lisp.net Fri Feb 25 07:58:12 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 25 Feb 2005 08:58:12 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/bochsrc.txt Message-ID: <20050225075812.9C6B08866B@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10533 Modified Files: bochsrc.txt Log Message: *** empty log message *** Date: Fri Feb 25 08:58:11 2005 Author: ffjeld Index: movitz/bochsrc.txt diff -u movitz/bochsrc.txt:1.6 movitz/bochsrc.txt:1.7 --- movitz/bochsrc.txt:1.6 Wed Jul 21 15:27:58 2004 +++ movitz/bochsrc.txt Fri Feb 25 08:58:10 2005 @@ -45,8 +45,7 @@ # disable the mouse, since DLX is text only mouse: enabled=0 -ne2k: ioaddr=0x280, irq=9, mac=00:40:05:18:66:d8, ethmod=fbsd, ethdev=xl0 -ne2k: ioaddr=0x300, irq=3, mac=00:40:05:18:66:d9, ethmod=fbsd, ethdev=xl0 +ne2k: ioaddr=0x300, irq=3, mac=00:40:05:18:66:d9, ethmod=fbsd, ethdev=nge0 # panic: action=report error: action=report From ffjeld at common-lisp.net Fri Feb 25 07:58:31 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 25 Feb 2005 08:58:31 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: <20050225075831.3B4C08866C@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10561 Modified Files: packages.lisp Log Message: *** empty log message *** Date: Fri Feb 25 08:58:28 2005 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.43 movitz/packages.lisp:1.44 --- movitz/packages.lisp:1.43 Fri Nov 26 15:59:14 2004 +++ movitz/packages.lisp Fri Feb 25 08:58:26 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2003-2004, +;;;; Copyright (C) 2003-2005, ;;;; Department of Computer Science, University of Tromsoe, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.43 2004/11/26 14:59:14 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.44 2005/02/25 07:58:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ From ffjeld at common-lisp.net Fri Feb 25 07:59:06 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 25 Feb 2005 08:59:06 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: <20050225075906.068DB8866B@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10585 Modified Files: basic-macros.lisp Log Message: Added movitz-type-location-offset. Date: Fri Feb 25 08:59:05 2005 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.54 movitz/losp/muerte/basic-macros.lisp:1.55 --- movitz/losp/muerte/basic-macros.lisp:1.54 Tue Jan 4 12:36:09 2005 +++ movitz/losp/muerte/basic-macros.lisp Fri Feb 25 08:59:04 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.54 2005/01/04 11:36:09 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.55 2005/02/25 07:59:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -409,6 +409,13 @@ (bt:slot-offset (intern (symbol-name (movitz:movitz-eval type env)) :movitz) (intern (symbol-name (movitz:movitz-eval slot env)) :movitz)))) +(define-compiler-macro movitz-type-location-offset (type slot &environment env) + (if (not (and (movitz:movitz-constantp type env) + (movitz:movitz-constantp slot env))) + (error "Non-constant movitz-type-slot-offset call.") + (truncate (+ -6 (bt:slot-offset (intern (symbol-name (movitz:movitz-eval type env)) :movitz) + (intern (symbol-name (movitz:movitz-eval slot env)) :movitz))) + 4))) (define-compiler-macro not (x) `(muerte::inlined-not ,x)) @@ -540,7 +547,7 @@ nil) (t (if (member type '(standard-gf-instance function pointer atom integer fixnum positive-fixnum cons symbol character null list - string vector simple-vector vector-u8 vector-u16 code-vector)) + string vector simple-vector vector-u8 vector-u16)) `(with-inline-assembly (:returns :nothing :labels (fail)) (:compile-form (:result-mode (:boolean-branch-on-false . check-type-failed)) (typep ,place ',type)) From ffjeld at common-lisp.net Fri Feb 25 07:59:35 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 25 Feb 2005 08:59:35 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp Message-ID: <20050225075935.467F68866B@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10604 Modified Files: inspect.lisp Log Message: Added location-in-code-vector-p%unsafe. Date: Fri Feb 25 08:59:31 2005 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.47 movitz/losp/muerte/inspect.lisp:1.48 --- movitz/losp/muerte/inspect.lisp:1.47 Wed Feb 2 10:12:54 2005 +++ movitz/losp/muerte/inspect.lisp Fri Feb 25 08:59:31 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.47 2005/02/02 09:12:54 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.48 2005/02/25 07:59:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -403,6 +403,16 @@ (+ -1 object-location #.(movitz::movitz-type-word-size :movitz-struct) (* 2 (truncate (+ (structure-object-length object) 1) 2)))))))) + +(defun location-in-code-vector-p%unsafe (code-vector location) + (and (<= (object-location code-vector) location) + (<= location + (+ -1 (object-location code-vector) + #.(movitz::movitz-type-word-size 'movitz-basic-vector) + (* 2 (truncate (+ (memref code-vector + (movitz-type-slot-offset 'movitz-basic-vector 'num-elements)) + 7) + 8)))))) (defun current-control-stack-depth (&optional (start-frame (current-stack-frame))) "How deep is the stack currently?" From ffjeld at common-lisp.net Fri Feb 25 08:00:20 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 25 Feb 2005 09:00:20 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp Message-ID: <20050225080020.350DE8866B@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10682 Modified Files: print.lisp Log Message: Minor change to the way errors are printed under *print-safely*. Date: Fri Feb 25 09:00:12 2005 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.17 movitz/losp/muerte/print.lisp:1.18 --- movitz/losp/muerte/print.lisp:1.17 Mon Jan 17 12:02:27 2005 +++ movitz/losp/muerte/print.lisp Fri Feb 25 09:00:11 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.17 2005/01/17 11:02:27 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.18 2005/02/25 08:00:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -194,7 +194,7 @@ (handler-case (internal-write object) (serious-condition (c) (print-unreadable-object (c *standard-output* :type t :identity t) - (format t " while printing ~Z" object)))))))) + (format t " (while printing ~Z)" object)))))))) (defun internal-write (object) (let ((stream *standard-output*)) From ffjeld at common-lisp.net Sun Feb 27 02:28:42 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 27 Feb 2005 03:28:42 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp Message-ID: <20050227022842.5A4ED8866C@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv21082 Modified Files: special-operators-cl.lisp Log Message: Cleaned up the way forwarding-bindings are set up, in the let compiler. Date: Sun Feb 27 03:28:39 2005 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.45 movitz/special-operators-cl.lisp:1.46 --- movitz/special-operators-cl.lisp:1.45 Thu Feb 3 10:18:45 2005 +++ movitz/special-operators-cl.lisp Sun Feb 27 03:28:33 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.45 2005/02/03 09:18:45 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.46 2005/02/27 02:28:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -98,7 +98,7 @@ else collect (let ((binding (make-instance 'located-binding :name var))) (movitz-env-add-binding local-env binding) - (compiler-values-bind (&code init-code &functional-p functional-p + (compiler-values-bind (&code init-code &functional-p functional-p &type type &returns init-register &final-form final-form) (compiler-call #'compile-form-to-register @@ -225,12 +225,19 @@ #+ignore (warn "replace ~S in ~S with outer ~S" binding (binding-funobj binding) (second (first init-code))) - (let ((target (second (first init-code)))) + (compiler-values-bind (&code new-init-code &final-form target) + (compiler-call #'compile-form-unprotected + :form init-form + :result-mode :ignore + :env init-env + :defaults all) + (check-type target lexical-binding) (change-class binding 'forwarding-binding :target-binding target) - `((:init-lexvar ,binding - :init-with-register ,target - :init-with-type ,target)))) + (append new-init-code + `((:init-lexvar ,binding + :init-with-register ,target + :init-with-type ,target))))) ((and (typep binding 'located-binding) (type-specifier-singleton type) (not (code-uses-binding-p body-code binding From ffjeld at common-lisp.net Sun Feb 27 02:30:39 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 27 Feb 2005 03:30:39 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20050227023039.626718866C@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv21191 Modified Files: compiler.lisp Log Message: Have compile-lexical-variable always return final-form, even when in :ignored mode. Date: Sun Feb 27 03:30:30 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.134 movitz/compiler.lisp:1.135 --- movitz/compiler.lisp:1.134 Wed Feb 2 08:48:58 2005 +++ movitz/compiler.lisp Sun Feb 27 03:30:22 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.134 2005/02/02 07:48:58 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.135 2005/02/27 02:30:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5704,7 +5704,8 @@ (check-type binding lexical-binding) (case (operator result-mode) (:ignore - (compiler-values ())) + (compiler-values () + :final-form binding)) (t (let ((returns (ecase (result-mode-type result-mode) ((:function :multiple-values :eax) :eax) From ffjeld at common-lisp.net Sun Feb 27 02:31:41 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 27 Feb 2005 03:31:41 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: <20050227023141.B1C768866C@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv21356 Modified Files: storage-types.lisp Log Message: Fix make-movitz-vector for lengths over (expt 2 14). Date: Sun Feb 27 03:31:36 2005 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.49 movitz/storage-types.lisp:1.50 --- movitz/storage-types.lisp:1.49 Mon Jan 17 11:54:21 2005 +++ movitz/storage-types.lisp Sun Feb 27 03:31:34 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.49 2005/01/17 10:54:21 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.50 2005/02/27 02:31:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -514,9 +514,12 @@ (:any-t (map 'vector #'movitz-read initial-contents)) (t initial-contents)) - :fill-pointer (if (integerp fill-pointer) - fill-pointer - size)))) + :fill-pointer (cond + ((not (typep size '(unsigned-byte 14))) + 0) + ((integerp fill-pointer) + fill-pointer) + (t size))))) (defun make-movitz-string (string) (make-movitz-vector (length string) From ffjeld at common-lisp.net Mon Feb 28 16:15:58 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 28 Feb 2005 17:15:58 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: <20050228161558.2CF39884E2@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv15120 Modified Files: debugger.lisp Log Message: Improved error-handling in backtrace. Date: Mon Feb 28 17:15:55 2005 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.32 movitz/losp/x86-pc/debugger.lisp:1.33 --- movitz/losp/x86-pc/debugger.lisp:1.32 Wed Feb 2 11:23:07 2005 +++ movitz/losp/x86-pc/debugger.lisp Mon Feb 28 17:15:53 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.32 2005/02/02 10:23:07 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.33 2005/02/28 16:15:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -507,115 +507,102 @@ (format t "{< ~D}" (stack-frame-call-site stack frame))) (when *backtrace-print-frames* (format t "#x~X " frame)))) - (typecase funobj - ((eql 0) - (let ((eip (dit-frame-ref stack frame :eip :unsigned-byte32)) - (casf (dit-frame-casf stack frame))) - (multiple-value-bind (function-name code-vector-offset) - (let ((casf-funobj (stack-frame-funobj stack casf))) - (cond - ((eq 0 casf-funobj) - (values 'default-interrupt-trampoline - (code-vector-offset (symbol-value 'default-interrupt-trampoline) - eip))) - ((not (typep casf-funobj 'function)) - ;; Hm.. very suspicius - (warn "Weird frame ~S" frame) - (values nil)) - (t (let ((x (code-vector-offset (funobj-code-vector casf-funobj) eip))) - (cond - ((not (eq nil x)) - (values (funobj-name casf-funobj) x)) - ((not (logbitp 10 (dit-frame-ref stack frame :eflags :unsigned-byte16))) - (let ((funobj2 (dit-frame-ref stack frame :esi :lisp))) - (or (when (typep funobj2 'function) - (let ((x (code-vector-offset (funobj-code-vector funobj2) eip))) - (when x - (values (funobj-name funobj2) x)))) - (find-primitive-code-vector-by-eip eip))))))))) - (setf next-frame (dit-frame-casf stack frame)) - (if (and conflate-interrupts conflate - ;; When the interrupted function has a stack-frame, conflate it. - (typep funobj 'function) - (= 1 (ldb (byte 1 5) (funobj-debug-info funobj)))) - (incf conflate-count) - (progn - (incf count) - (print-leadin stack frame count conflate-count) - (setf conflate-count 0) - (let ((exception (dit-frame-ref stack frame :exception-vector :unsigned-byte32))) - (if function-name - (format t "DIT exception ~D in ~W at PC offset ~D." - exception - function-name - code-vector-offset) - (format t "DIT exception ~D at EIP=~S with ESI=~S." - exception - eip - (dit-frame-ref stack frame :esi :unsigned-byte32))) - #+ignore - (typecase funobj - (function - (let ((delta (code-vector-offset (funobj-code-vector funobj) eip))) - (if delta - (format t "DIT Exception ~D in ~W at PC offset ~D." - exception (funobj-name funobj) delta) - (multiple-value-bind (primitive-name primitive-vector) - (find-primitive-code-vector-by-location (truncate eip 4)) - (if (not primitive-name) - (format t "DIT Exception ~D in ~W at EIP=#x~X." - exception (funobj-name funobj) eip) - (format t "DIT Exception ~D in primitive-function ~A at PC offset ~D." - exception - primitive-name - (code-vector-offset primitive-vector eip))))))) - (t ;; This should in principle never happen, but since this - ;; is a debugger, making this an error or break would probably - ;; just be a nuisance. - (format t "DIT Exception ~D. Unable to determine current function (!) 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) - #+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) - (setf conflate-count 0) - (write-char #\() - (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)))) - (format t "{unbound ~S}" real-name))) - ((and (car map) - (member name +backtrace-gf-discriminatior-functions+)) - (let ((gf (stack-frame-ref stack frame (car map)))) + (handler-case + (typecase funobj + ((eql 0) + (let ((eip (dit-frame-ref stack frame :eip :unsigned-byte32)) + (casf (dit-frame-casf stack frame))) + (multiple-value-bind (function-name code-vector-offset) + (let ((casf-funobj (stack-frame-funobj stack casf))) (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))) - (t (write name) - (safe-print-stack-frame-arglist stack frame map - :numargs numargs - :edx-p (eq 'muerte::&edx - (car (funobj-lambda-list funobj))))))) - (write-char #\)) - (when (and (symbolp name) - (string= name 'toplevel-function)) - (write-char #\.) - (return)))))) - (t (print-leadin stack frame count conflate-count) - (format t "?: ~Z" funobj)))))) + ((eq 0 casf-funobj) + (values 'default-interrupt-trampoline + (code-vector-offset (symbol-value 'default-interrupt-trampoline) + eip))) + ((not (typep casf-funobj 'function)) + ;; Hm.. very suspicius + (warn "Weird frame ~S" frame) + (values nil)) + (t (let ((x (code-vector-offset (funobj-code-vector casf-funobj) eip))) + (cond + ((not (eq nil x)) + (values (funobj-name casf-funobj) x)) + ((not (logbitp 10 (dit-frame-ref stack frame :eflags :unsigned-byte16))) + (let ((funobj2 (dit-frame-ref stack frame :esi :lisp))) + (or (when (typep funobj2 'function) + (let ((x (code-vector-offset (funobj-code-vector funobj2) eip))) + (when x + (values (funobj-name funobj2) x)))) + (find-primitive-code-vector-by-eip eip))))))))) + ;; (setf next-frame (dit-frame-casf stack frame)) + (if (and conflate-interrupts conflate + ;; When the interrupted function has a stack-frame, conflate it. + (typep funobj 'function) + (= 1 (ldb (byte 1 5) (funobj-debug-info funobj)))) + (incf conflate-count) + (progn + (incf count) + (print-leadin stack frame count conflate-count) + (setf conflate-count 0) + (let ((exception (dit-frame-ref stack frame :exception-vector :unsigned-byte32))) + (if function-name + (format t "DIT exception ~D in ~W at PC offset ~D." + exception + function-name + code-vector-offset) + (format t "DIT exception ~D at EIP=~S with ESI=~S." + exception + eip + (dit-frame-ref stack frame :esi :unsigned-byte32))))))))) + (function + (let ((name (funobj-name funobj))) + (cond + ((and conflate (member name *backtrace-conflate-names* :test #'equal)) + (incf conflate-count)) + (t (incf count) + #+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) + (setf conflate-count 0) + (write-char #$) + (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)))) + (format t "{unbound ~S}" real-name))) + ((and (car map) + (member name +backtrace-gf-discriminatior-functions+)) + (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))) + (t (write name) + (safe-print-stack-frame-arglist stack frame map + :numargs numargs + :edx-p (eq 'muerte::&edx + (car (funobj-lambda-list funobj))))))) + (write-char #$) + (when (and (symbolp name) + (string= name 'toplevel-function)) + (write-char #\.) + (return)) + (write-char #\newline))))) + (t (print-leadin stack frame count conflate-count) + (format t "?: ~Z" funobj))) + (serious-condition (c) + (let ((*print-safely* t)) + (format t " - Error at ~S funobj ~S: ~A" + frame + (stack-frame-funobj nil frame) + c))))))) (values)) From ffjeld at common-lisp.net Mon Feb 28 16:44:38 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 28 Feb 2005 17:44:38 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: <20050228164438.27E01884E2@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv16359 Modified Files: debugger.lisp Log Message: Fixed buglet in *call-site-patterns*, the function-value offset for symbols was out of sync. Should fix some {eax unknown}s in backtrace. Date: Mon Feb 28 17:44:37 2005 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.33 movitz/losp/x86-pc/debugger.lisp:1.34 --- movitz/losp/x86-pc/debugger.lisp:1.33 Mon Feb 28 17:15:53 2005 +++ movitz/losp/x86-pc/debugger.lisp Mon Feb 28 17:44:37 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.33 2005/02/28 16:15:53 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.34 2005/02/28 16:44:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -235,7 +235,7 @@ ))) (:* 1 ((:or ((:or (#x8b #x56 (:edx :esi)) ; (:movl (:esi x) :edx) (#x8b #x54 #x37 (:edx :esi+edi))) ;# %EDX> - #x8b #x72 #xfd) ; (:movl (:edx -3) :esi) + #x8b #x72 #xf9) ; (:movl (:edx -7) :esi) (#x8b #x74 #x7e (:any-offset)) ; # %ESI> (#x8b #x76 (:any-offset))))) ; # %ESI> (:* 1 ((:or (#xb1 (:cl-numargs))))) ; (:movb x :cl) From ffjeld at common-lisp.net Mon Feb 28 17:00:11 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 28 Feb 2005 18:00:11 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp Message-ID: <20050228170011.D3DAE884E2@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17272 Modified Files: inspect.lisp Log Message: Improved copy-current-control-stack. Date: Mon Feb 28 18:00:09 2005 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.48 movitz/losp/muerte/inspect.lisp:1.49 --- movitz/losp/muerte/inspect.lisp:1.48 Fri Feb 25 08:59:31 2005 +++ movitz/losp/muerte/inspect.lisp Mon Feb 28 18:00:05 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.48 2005/02/25 07:59:31 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.49 2005/02/28 17:00:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -93,8 +93,8 @@ (let ((pos (+ frame index))) (assert (< -1 pos (length stack)) () "Index ~S, pos ~S, len ~S" index pos (length stack)) - (memref stack 2 :index pos :type type))) - (t (memref frame 0 :index index :type type)))) + (memref stack (+ 2 (* 4 pos)) :type type))) + (t (memref frame (* 4 index) :type type)))) (defun (setf stack-frame-ref) (value stack frame index &optional (type ':lisp)) (cond @@ -428,11 +428,29 @@ (stack-frame-ref nil start-frame i :unsigned-byte32))) (do ((frame start-frame)) ((eq 0 frame)) - (let ((uplink (stack-frame-uplink nil frame))) + (let ((uplink (stack-frame-uplink nil frame)) + (copy-frame (- frame start-frame))) (unless (= 0 uplink) - (setf (stack-frame-ref copy 0 (- frame start-frame) :lisp) + (setf (stack-frame-ref copy copy-frame 0 :lisp) (- uplink start-frame)) - - ) + (unless (= 0 copy-frame) ; first frame has only uplink. + ;; Now, make any raw stack-pointers into relative indexes. + ;; XXX TODO: The dynamic-env list. + (case (stack-frame-funobj copy copy-frame) + (0 (let ((ebp (dit-frame-ref nil frame :ebp))) + (setf (dit-frame-ref copy copy-frame :ebp) + (etypecase ebp + (fixnum (- ebp start-frame)) + (null nil)))) + (let ((ac (dit-frame-ref copy copy-frame + :atomically-continuation + :location))) + (when (and (/= 0 ac) + (= 0 (ldb (byte 2 0) + (dit-frame-ref copy copy-frame + :atomically-continuation + :unsigned-byte8)))) + (setf (dit-frame-ref copy copy-frame :atomically-continuation) + (- ac start-frame)))))))) (setf frame uplink))) copy)) From ffjeld at common-lisp.net Mon Feb 28 23:34:03 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 1 Mar 2005 00:34:03 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: <20050228233403.442F0884E2@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv7331 Modified Files: debugger.lisp Log Message: Added find-function-name. Date: Tue Mar 1 00:34:02 2005 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.34 movitz/losp/x86-pc/debugger.lisp:1.35 --- movitz/losp/x86-pc/debugger.lisp:1.34 Mon Feb 28 17:44:37 2005 +++ movitz/losp/x86-pc/debugger.lisp Tue Mar 1 00:34:02 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.34 2005/02/28 16:44:37 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.35 2005/02/28 23:34:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -606,3 +606,20 @@ c))))))) (values)) +(defun find-function-name (instruction-location) + "Try to find a name bound to a function whose code-vector matches instruction-location." + (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)))) + (do-all-symbols (symbol) + (when (and (fboundp symbol) + (location-in-code-vector-p%unsafe (funobj-code-vector (symbol-function symbol)) + instruction-location)) + (return symbol)) + (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)))))) From ffjeld at common-lisp.net Mon Feb 28 23:36:22 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 1 Mar 2005 00:36:22 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/packages.lisp Message-ID: <20050228233622.8D5A5884E2@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7392 Modified Files: packages.lisp Log Message: Improved do-all-symbols expansion so that (block nil ...) is installed correctly. Date: Tue Mar 1 00:36:15 2005 Author: ffjeld Index: movitz/losp/muerte/packages.lisp diff -u movitz/losp/muerte/packages.lisp:1.6 movitz/losp/muerte/packages.lisp:1.7 --- movitz/losp/muerte/packages.lisp:1.6 Sat Nov 13 15:50:13 2004 +++ movitz/losp/muerte/packages.lisp Tue Mar 1 00:36:08 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001, 2002-2004 +;;;; Copyright (C) 2001, 2002-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 ;;;; Created at: Thu Aug 30 15:19:43 2001 ;;;; -;;;; $Id: packages.lisp,v 1.6 2004/11/13 14:50:13 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.7 2005/02/28 23:36:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -105,10 +105,11 @@ (dummy (gensym)) (package-var (gensym)) (package-hash-var (gensym)) - (state-var (gensym "do-all-symbols-state-")) (next-symbol (gensym)) (more-symbols-var (gensym)) - (symbol-var (gensym))) + (symbol-var (gensym)) + (loop-tag (gensym)) + (end-tag (gensym))) `(with-hash-table-iterator (,next-package (get-global-property :packages)) (do () (nil) (multiple-value-bind (,more-packages-var ,dummy ,package-var) @@ -116,18 +117,22 @@ (declare (ignore ,dummy)) (unless ,more-packages-var (return ,result-form)) - (do ((,state-var '(:externals :internals) (cdr ,state-var)) - (,package-hash-var (package-object-external-symbols ,package-var) - (package-object-internal-symbols ,package-var))) - ((null ,state-var)) - (with-hash-table-iterator (,next-symbol ,package-hash-var) - (do () (nil) - (multiple-value-bind (,more-symbols-var ,dummy ,symbol-var) - (,next-symbol) - (declare (ignore ,dummy)) - (unless ,more-symbols-var (return nil)) - (let ((,var ,symbol-var)) - , at declarations-and-body)))))))))) + (let ((,package-hash-var (package-object-external-symbols ,package-var))) + (tagbody ,loop-tag + (with-hash-table-iterator (,next-symbol ,package-hash-var) + (tagbody ,loop-tag + (multiple-value-bind (,more-symbols-var ,dummy ,symbol-var) + (,next-symbol) + (declare (ignore ,dummy)) + (unless ,more-symbols-var (go ,end-tag)) + (let ((,var ,symbol-var)) + , at declarations-and-body)) + (go ,loop-tag) + ,end-tag)) + (let ((internals (package-object-internal-symbols ,package-var))) + (unless (eq ,package-hash-var internals) + (setf ,package-hash-var internals) + (go ,loop-tag)))))))))) (defmacro do-external-symbols ((var &optional (package *package*) result-form) &body declarations-and-body) (let ((next-var (gensym)) @@ -185,3 +190,5 @@ (do-all-symbols (symbol) (apropos-symbol symbol string))))) (values)) + + From ffjeld at common-lisp.net Mon Feb 28 23:38:08 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 1 Mar 2005 00:38:08 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: <20050228233808.7FE4E884E2@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7432 Modified Files: basic-macros.lisp Log Message: Fixed boundp to accept nil as argument. Date: Tue Mar 1 00:38:05 2005 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.55 movitz/losp/muerte/basic-macros.lisp:1.56 --- movitz/losp/muerte/basic-macros.lisp:1.55 Fri Feb 25 08:59:04 2005 +++ movitz/losp/muerte/basic-macros.lisp Tue Mar 1 00:38:03 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.55 2005/02/25 07:59:04 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.56 2005/02/28 23:38:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1059,8 +1059,8 @@ `(with-inline-assembly-case () (do-case (t :boolean-zf=0 :labels (boundp-done)) (:compile-form (:result-mode :ebx) ,symbol) - (:leal (:ebx ,(- (movitz:tag :symbol))) :ecx) - (:testb 7 :cl) + (:leal (:ebx ,(- (movitz:tag :null))) :ecx) + (:testb 5 :cl) (:jne '(:sub-program () (:int 66))) (:call-local-pf dynamic-variable-lookup) (:globally (:cmpl (:edi (:edi-offset new-unbound-value)) :eax))))) From ffjeld at common-lisp.net Mon Feb 28 23:39:05 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 1 Mar 2005 00:39:05 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp Message-ID: <20050228233905.661E6884E2@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7466 Modified Files: typep.lisp Log Message: Added (typep code-vector) Date: Tue Mar 1 00:39:04 2005 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.41 movitz/losp/muerte/typep.lisp:1.42 --- movitz/losp/muerte/typep.lisp:1.41 Tue Jan 25 14:55:36 2005 +++ movitz/losp/muerte/typep.lisp Tue Mar 1 00:39:04 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.41 2005/01/25 13:55:36 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.42 2005/02/28 23:39:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -577,6 +577,9 @@ (define-simple-typep (hash-table hash-table-p)) (define-simple-typep (package packagep)) + +(define-simple-typep (code-vector code-vector-p) (x) + (typep x 'code-vector)) ;;;