movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp
by ffjeld＠common-lisp.net 26 Apr '05

26 Apr '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1578 Modified Files: run-time-context.lisp Log Message: *** empty log message *** Date: Wed Apr 27 01:43:56 2005 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.15 movitz/losp/muerte/run-time-context.lisp:1.16 --- movitz/losp/muerte/run-time-context.lisp:1.15 Mon Oct 11 15:53:19 2004 +++ movitz/losp/muerte/run-time-context.lisp Wed Apr 27 01:43:56 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 <frodef(a)acm.org> ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.15 2004/10/11 13:53:19 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.16 2005/04/26 23:43:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -113,39 +113,39 @@ (defun clone-run-time-context (&key (parent (current-run-time-context)) (name :anonymous)) (check-type parent run-time-context) - (let ((context (%shallow-copy-object parent #.(movitz::movitz-type-word-size 'movitz-run-time-context)))) + (let ((context (%shallow-copy-object parent (movitz-type-word-size 'movitz-run-time-context)))) (setf (%run-time-context-slot 'name context) name - (%run-time-context-slot 'self context) context) - (setf (%run-time-context-segment-base 'segment-descriptor-thread-context context) - (+ (* #.movitz::+movitz-fixnum-factor+ (object-location context)) - (%run-time-context-slot 'physical-address-offset))) + (%run-time-context-slot 'self context) context + (%run-time-context-slot 'atomically-continuation context) 0) context)) -(defun switch-to-context (context) - (check-type context run-time-context) - (with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :eax) context) - (:movw #.(cl:1- (cl:* 8 8)) (:esp -6)) - (:addl #.(cl:+ -6 (movitz::global-constant-offset 'movitz::segment-descriptor-table)) - :eax) - (:addl :edi :eax) - (:locally (:addl (:edi (:edi-offset physical-address-offset)) :eax)) - (:movl :eax (:esp -4)) - (:lgdt (:esp -6)) - (:movw #x28 :ax) - (:movw :ax :fs) - (:locally (:movl (:edi (:edi-offset self)) :eax)))) - -(defun %run-time-context-install-stack (context &optional (stack-vector - (make-array 8192 :element-type 'u32)) - (cushion 1024)) - (check-type stack-vector vector) - (assert (< cushion (array-dimension stack-vector 0))) - (setf (%run-time-context-slot 'stack-vector context) stack-vector) +;;;(defun switch-to-context (context) +;;; (check-type context run-time-context) +;;; (with-inline-assembly (:returns :nothing) +;;; (:compile-form (:result-mode :eax) context) +;;; (:movw #.(cl:1- (cl:* 8 8)) (:esp -6)) +;;; (:addl #.(cl:+ -6 (movitz::global-constant-offset 'movitz::segment-descriptor-table)) +;;; :eax) +;;; (:addl :edi :eax) +;;; (:locally (:addl (:edi (:edi-offset physical-address-offset)) :eax)) +;;; (:movl :eax (:esp -4)) +;;; (:lgdt (:esp -6)) +;;; (:movw #x28 :ax) +;;; (:movw :ax :fs) +;;; (:locally (:movl (:edi (:edi-offset self)) :eax)))) + +(defun %run-time-context-install-stack (context + &optional (control-stack + (make-array 8192 :element-type '(unsigned-byte 32))) + (cushion 1024)) + (check-type control-stack vector) + (assert (< cushion (array-dimension control-stack 0))) + (setf (%run-time-context-slot 'control-stack context) control-stack) (setf (%run-time-context-slot 'stack-top context) - (+ (object-location stack-vector) 8 - (* 4 (array-dimension stack-vector 0)))) + (+ (object-location control-stack) 8 + (* 4 (array-dimension control-stack 0)))) (setf (%run-time-context-slot 'stack-bottom context) - (+ (object-location stack-vector) 8 + (+ (object-location control-stack) 8 (* 4 cushion))) - stack-vector) + control-stack) +

1 0

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

26 Apr '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1544 Modified Files: conditions.lisp Log Message: Have condition argument to invoke-debugger be optional. Date: Wed Apr 27 01:40:30 2005 Author: ffjeld Index: movitz/losp/muerte/conditions.lisp diff -u movitz/losp/muerte/conditions.lisp:1.13 movitz/losp/muerte/conditions.lisp:1.14 --- movitz/losp/muerte/conditions.lisp:1.13 Tue Nov 2 16:52:21 2004 +++ movitz/losp/muerte/conditions.lisp Wed Apr 27 01:40:29 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.13 2004/11/02 15:52:21 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.14 2005/04/26 23:40:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -270,7 +270,7 @@ (signal-simple 'simple-condition datum args) nil) -(defun invoke-debugger (condition) +(defun invoke-debugger (&optional condition) (when *debugger-hook* (let ((hook *debugger-hook*) (*debugger-hook* nil))

1 0

[movitz-cvs] CVS update: movitz/losp/ll-testing.lisp
by ffjeld＠common-lisp.net 26 Apr '05

26 Apr '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv29766 Modified Files: ll-testing.lisp Log Message: Threads have landed! Date: Wed Apr 27 00:23:14 2005 Author: ffjeld Index: movitz/losp/ll-testing.lisp diff -u movitz/losp/ll-testing.lisp:1.3 movitz/losp/ll-testing.lisp:1.4 --- movitz/losp/ll-testing.lisp:1.3 Mon Apr 18 09:08:58 2005 +++ movitz/losp/ll-testing.lisp Wed Apr 27 00:23:14 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Apr 14 08:18:43 2005 ;;;; -;;;; $Id: ll-testing.lisp,v 1.3 2005/04/18 07:08:58 ffjeld Exp $ +;;;; $Id: ll-testing.lisp,v 1.4 2005/04/26 22:23:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -43,9 +43,7 @@ (check-type entries (integer 0 *)) (let ((limit (1- (* 8 entries))) (base (+ 2 (+ (object-location table) - (memref nil (movitz-type-slot-offset 'movitz-run-time-context - 'physical-address-offset) - :type :lisp))))) + (location-physical-offset))))) (%lgdt base limit) (values table limit)))) @@ -54,8 +52,224 @@ (loop for i from start below end do (format t "~&~2D: base: #x~8,'0X, limit: #x~5,'0X, type-s-dpl-p: ~8,'0b, avl-x-db-g: ~4,'0b~%" i - (segment-descriptor-base table i) + (* 4 (segment-descriptor-base-location table i)) (segment-descriptor-limit table i) (segment-descriptor-type-s-dpl-p table i) (segment-descriptor-avl-x-db-g table i))) - (values)) \ No newline at end of file + (values)) + + + +(defmacro control-stack-esp (stack) + `(stack-frame-ref ,stack 0 1)) + +(defmacro control-stack-ebp (stack) + `(stack-frame-ref ,stack 0 0)) + +(defun control-stack-init (&optional (stack (make-array 254 :element-type '(unsigned-byte 32)))) + (let ((i (length stack))) + (setf (control-stack-esp stack) i + (control-stack-ebp stack) 0) + stack)) + +(defun control-stack-push (value stack &optional (type :lisp)) + (let ((i (decf (control-stack-esp stack)))) + (assert (< 1 i (length stack))) + (setf (stack-frame-ref stack i 0 type) value))) + +(defun control-stack-enter-frame (stack &optional function) + (control-stack-push (control-stack-ebp stack) stack) + (setf (control-stack-ebp stack) (control-stack-esp stack)) + (when function + (check-type function function) + (control-stack-push function stack)) + stack) + +(defun stack-stopper (&rest args) + (declare (ignore args)) + (declare (without-function-prelude)) + (error "Stack stop.") + (format *terminal-io* "~&Stack-stopper halt.") + (loop (halt-cpu))) + +(defun control-stack-fixate (stack) + (let ((stack-base (+ 2 (object-location stack)))) + (do ((frame (control-stack-ebp stack))) + ((zerop (stack-frame-uplink stack frame))) + (assert (typep (stack-frame-funobj stack frame) 'function)) + (let ((previous-frame frame)) + (setf frame (stack-frame-uplink stack frame)) + (incf (stack-frame-ref stack previous-frame 0) + stack-base))) + (values (+ (control-stack-ebp stack) stack-base) + (+ (control-stack-esp stack) stack-base)))) + +(defun make-thread (segment-descriptor-table) + (let* ((fs-index 8) + (thread (muerte::clone-run-time-context :name 'subthread))) + (setf (segment-descriptor segment-descriptor-table fs-index) + (segment-descriptor segment-descriptor-table (truncate (segment-register :fs) 8))) + (warn "Thread ~S FS base: ~S" + thread + (setf (segment-descriptor-base-location segment-descriptor-table fs-index) + (+ (object-location thread) + (muerte::location-physical-offset)))) + (values thread (* 8 fs-index)))) + + +(defun control-stack-bootstrap (stack function &rest args) + (declare (dynamic-extent args)) + (check-type function function) + (control-stack-init stack) + (control-stack-push 0 stack) + (control-stack-enter-frame stack #'stack-stopper) + (let ((stack-top (+ (object-location stack) 2 (length stack))) + (stack-bottom (+ (object-location stack) 2))) + (dolist (arg (cddr args)) + (control-stack-push arg stack)) + (control-stack-push (+ 2 1 (object-location (funobj-code-vector #'stack-stopper))) + stack) ; XXX The extra word skips the frame-setup. + (multiple-value-bind (ebp esp) + (control-stack-fixate stack) + (stack-yield stack esp ebp + :eax (car args) + :ebx (cadr args) + :ecx (length args) + :esi function))) + stack) + +(defun test-tt () + (multiple-value-bind (thread stack) + (muerte.init::threading) + (control-stack-bootstrap stack #'format t "Hello world!"))) + +(defun test-tr (function &rest args) + (declare (dynamic-extent args)) + (assert (= 2 (length args))) + (multiple-value-bind (thread fs) + (make-thread muerte.init::*segment-descriptor-table*) + (let ((cushion nil) + (stack (control-stack-init-for-yield (make-array 4094 :element-type '(unsigned-byte 32)) + function args))) + (multiple-value-bind (ebp esp) + (control-stack-fixate stack) + (setf (control-stack-ebp stack) ebp + (control-stack-esp stack) esp)) + (setf (%run-time-context-slot 'dynamic-env thread) 0 + (%run-time-context-slot 'stack-vector thread) stack + (%run-time-context-slot 'stack-top thread) (+ 2 (object-location stack) + (length stack)) + (%run-time-context-slot 'stack-bottom thread) (+ (object-location stack) 2 + (or cushion + (if (>= (length stack) 200) + 100 + 0)))) + (values thread fs stack)))) + +(defun stack-bootstrapper (&rest args) + (declare (ignore args)) + (with-inline-assembly (:returns :nothing) (:break)) + (let ((frame (current-stack-frame))) + (assert (eql 0 (stack-frame-uplink nil frame))) + (let ((function (stack-frame-ref nil frame 1)) + (numargs (stack-frame-ref nil frame 2))) + (warn "[~S] bootstrapping function ~S with ~D args." frame function numargs) + (check-type function function) + (check-type numargs (integer 0 #xffff)) + (with-inline-assembly (:returns :multiple-values) + (:load-lexical (:lexical-binding function) :esi) + (:movl (:ebp #x0c) :eax) + (:movl (:ebp #x10) :ebx) + (:call (:esi (:offset movitz-funobj code-vector%2op)))))) + (error "Stack bootstrapper stop.") + (format *terminal-io* "~&stack-bootstrapper halt.") + (loop (halt-cpu))) + +(defun control-stack-init-for-yield (stack function args) + (check-type function function) + (control-stack-init stack) + (control-stack-push (second args) stack) + (control-stack-push (first args) stack) + (control-stack-push (length args) stack) + (control-stack-push function stack) + (control-stack-enter-frame stack #'stack-bootstrapper) + ;; Now pretend stack-bootstrapper called yield. First, the return address + (control-stack-push (+ 2 2 (object-location (funobj-code-vector #'stack-bootstrapper))) + stack) ; XXX The extra 2 words skip the frame-setup, + ; XXX which happens to be 8 bytes.. + (control-stack-enter-frame stack #'yield) + (control-stack-push 0 stack) ; XXX shouldn't need this? + stack) + + +(defun yield (target-rtc fs) + (assert (not (eq target-rtc (current-run-time-context)))) + (let ((my-stack (%run-time-context-slot 'stack-vector)) + (target-stack (%run-time-context-slot 'stack-vector target-rtc))) + (assert (not (eq my-stack target-stack))) + (let ((esp (control-stack-esp target-stack)) + (ebp (control-stack-ebp target-stack))) + (assert (location-in-object-p target-stack esp)) + (assert (location-in-object-p target-stack ebp)) + (assert (eq (memref ebp -4) (asm-register :esi)) () + "Cannot yield to a non-yield frame.") + ;; Push eflags for later.. + (setf (memref (decf esp) 0) (eflags)) + ;; Enable someone to yield back here.. + (setf (control-stack-ebp my-stack) (asm-register :ebp) + (control-stack-esp my-stack) (asm-register :esp)) + (with-inline-assembly (:returns :nothing) + (:cli) + (:load-lexical (:lexical-binding fs) :untagged-fixnum-ecx) + (:movw :cx :fs) + (:load-lexical (:lexical-binding ebp) :eax) + (:load-lexical (:lexical-binding esp) :ebx) + (:movl :eax :ebp) + (:movl :ebx :esp) + (:popfl))))) + +(defun stack-yield (stack esp ebp &key eax ebx ecx edx esi eflags (dynamic-env 0) cushion) + "Activate stack for the current run-time-context, and load the indicated CPU state. +EIP is loaded from ESI's code-vector." + (assert (not (eq stack (%run-time-context-slot 'stack-vector)))) + (assert (location-in-object-p stack esp)) + (assert (location-in-object-p stack ebp)) + (assert (or (= 0 dynamic-env) (location-in-object-p stack dynamic-env))) + (let ((stack-top (+ (object-location stack) 2 (length stack))) + (stack-bottom (+ (object-location stack) 2 + (or cushion + (if (>= (length stack) 200) + 100 + 0))))) + (with-inline-assembly (:returns :non-local-exit) + (:clc) + (:pushfl) + (:popl :ebx) + (:compile-form (:result-mode :eax) eflags) + (:cmpl :edi :eax) + (:je 'no-eflags-provided) + (:movl :eax :ebx) + no-eflags-provided + (:locally (:movl :ebx (:edi (:edi-offset raw-scratch0)))) ; Keep eflags in raw-scratch0 + (:cli) ; Disable interrupts for a little while + (:compile-form (:result-mode :eax) stack) + (:locally (:movl :eax (:edi (:edi-offset stack-vector)))) + (:compile-form (:result-mode :eax) dynamic-env) + (:locally (:movl :eax (:edi (:edi-offset dynamic-env)))) + (:compile-two-forms (:eax :ebx) stack-top stack-bottom) + (:locally (:movl :eax (:edi (:edi-offset stack-top)))) + (:locally (:movl :ebx (:edi (:edi-offset stack-bottom)))) + + (:compile-two-forms (:eax :ebx) esp ebp) + (:locally (:movl :eax (:edi (:edi-offset scratch1)))) + (:locally (:movl :ebx (:edi (:edi-offset scratch2)))) + + (:compile-form (:result-mode :untagged-fixnum-ecx) ecx) + (:compile-two-forms (:eax :ebx) eax ebx) + (:compile-two-forms (:edx :esi) edx esi) + (:locally (:movl (:edi (:edi-offset scratch1)) :esp)) + (:locally (:movl (:edi (:edi-offset scratch2)) :ebp)) + (:locally (:pushl (:edi (:edi-offset raw-scratch0)))) ; reset eflags + (:popfl) + (:jmp (:esi (:offset movitz-funobj code-vector)))))) +

1 0

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

24 Apr '05

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv22464 Modified Files: debugger.lisp Log Message: *** empty log message *** Date: Mon Apr 25 00:13:54 2005 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.38 movitz/losp/x86-pc/debugger.lisp:1.39 --- movitz/losp/x86-pc/debugger.lisp:1.38 Wed Apr 20 08:54:07 2005 +++ movitz/losp/x86-pc/debugger.lisp Mon Apr 25 00:13:54 2005 @@ -6,11 +6,11 @@ ;;;; For distribution policy, see the accompanying file COPYING. ;;;; ;;;; Filename: debugger.lisp -;;;; Description: +;;;; Description: Debugging functionality. ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.38 2005/04/20 06:54:07 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.39 2005/04/24 22:13:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -38,7 +38,8 @@ muerte::do-slow-method-lookup muerte::initial-discriminating-function muerte::discriminating-function-max - muerte::discriminating-function-max-step2)) + muerte::discriminating-function-max-step2 + invoke-debugger-on-designator)) (defconstant +backtrace-gf-discriminatior-functions+ '(muerte::discriminating-function-max @@ -132,12 +133,12 @@ (stack-frame-call-site stack frame) (when (and call-site code) (dolist (map +call-site-numargs-maps+ - (warn "no match at ~D for ~S frame ~S [~S]." - call-site - (stack-frame-funobj stack (stack-frame-uplink stack frame)) - frame funobj)) + #+ignore (warn "no match at ~D for ~S frame ~S [~S]." + call-site + (stack-frame-funobj stack (stack-frame-uplink stack frame)) + frame funobj)) (when (not (mismatch code (cdr map) - :start1 (- call-site (length (cdr map))) + :start1 (max 0 (- call-site (length (cdr map)))) :end1 call-site)) (return (cond @@ -600,10 +601,11 @@ (format t "?: ~Z" funobj))) (serious-condition (c) (let ((*print-safely* t)) - (format t " - Error at ~S funobj ~S: ~A" + (format t " - Backtracing error at ~S funobj ~S: ~A" frame (stack-frame-funobj nil frame) - c))))))) + c))))) + until (zerop (stack-frame-uplink stack frame)))) (values)) (defun locate-function (instruction-location)

1 0

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

24 Apr '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22434 Modified Files: segments.lisp Log Message: *** empty log message *** Date: Mon Apr 25 00:11:24 2005 Author: ffjeld Index: movitz/losp/muerte/segments.lisp diff -u movitz/losp/muerte/segments.lisp:1.11 movitz/losp/muerte/segments.lisp:1.12 --- movitz/losp/muerte/segments.lisp:1.11 Mon Apr 18 09:07:45 2005 +++ movitz/losp/muerte/segments.lisp Mon Apr 25 00:11:24 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu May 8 14:25:06 2003 ;;;; -;;;; $Id: segments.lisp,v 1.11 2005/04/18 07:07:45 ffjeld Exp $ +;;;; $Id: segments.lisp,v 1.12 2005/04/24 22:11:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -161,26 +161,31 @@ (:cr4 (set-creg :cr4))) value)) -(defun segment-descriptor-base (table index) +(defun segment-descriptor-base-location (table index) (check-type table (and vector (not simple-vector))) + (eval-when (:compile-toplevel) + (assert (= 4 movitz::+movitz-fixnum-factor+))) + ;; XXX This fails for locations above 2GB. (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)))) (logior (ash (memref table (+ 7 offset) :type :unsigned-byte8) - 24) + 22) (ash (memref table (+ 4 offset) :type :unsigned-byte8) - 16) + 14) (ash (memref table (+ 2 offset) :type :unsigned-byte16) - 0)))) + -2)))) -(defun (setf segment-descriptor-base) (base table index) +(defun (setf segment-descriptor-base-location) (base-location table index) (check-type table (and vector (not simple-vector))) + (eval-when (:compile-toplevel) + (assert (= 4 movitz::+movitz-fixnum-factor+))) (let ((offset (+ (* index 8) (movitz-type-slot-offset 'movitz-basic-vector 'data)))) (setf (memref table (+ 7 offset) :type :unsigned-byte8) - (ldb (byte 8 24) base)) + (ldb (byte 8 22) base-location)) (setf (memref table (+ 4 offset) :type :unsigned-byte8) - (ldb (byte 8 16) base)) + (ldb (byte 8 14) base-location)) (setf (memref table (+ 2 offset) :type :unsigned-byte16) - (ldb (byte 16 0) base)) - base)) + (ash (ldb (byte 14 0) base-location) 2)) + base-location)) (defun segment-descriptor-limit (table index) (check-type table (and vector (not simple-vector)))

1 0

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

24 Apr '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22412 Modified Files: inspect.lisp Log Message: Have (stack-frame-uplink 0) return 0. Date: Mon Apr 25 00:10:26 2005 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.50 movitz/losp/muerte/inspect.lisp:1.51 --- movitz/losp/muerte/inspect.lisp:1.50 Wed Apr 20 08:51:12 2005 +++ movitz/losp/muerte/inspect.lisp Mon Apr 25 00:10:26 2005 @@ -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.50 2005/04/20 06:51:12 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.51 2005/04/24 22:10:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -47,9 +47,11 @@ (+ (object-location stack) 2 index))) (defun stack-frame-uplink (stack frame) - (if (eq 0 (stack-frame-funobj stack frame)) - (dit-frame-casf stack frame) - (stack-frame-ref stack frame 0))) + (cond + ((eq 0 frame) 0) + ((eq 0 (stack-frame-funobj stack frame)) + (dit-frame-casf stack frame)) + (t (stack-frame-ref stack frame 0)))) (defun stack-vector-designator (stack) (etypecase stack

1 0

[movitz-cvs] CVS update: movitz/special-operators.lisp
by ffjeld＠common-lisp.net 24 Apr '05

24 Apr '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv22371 Modified Files: special-operators.lisp Log Message: Fixed bug in inline-values: stack was not reset properly for >= 3 values. Date: Mon Apr 25 00:08:39 2005 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.49 movitz/special-operators.lisp:1.50 --- movitz/special-operators.lisp:1.49 Thu Feb 3 10:18:51 2005 +++ movitz/special-operators.lisp Mon Apr 25 00:08:39 2005 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.49 2005/02/03 09:18:51 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.50 2005/04/24 22:08:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1115,9 +1115,12 @@ (t (multiple-value-bind (arguments-code stack-displacement arguments-modifies arguments-types arguments-functional-p) (make-compiled-argument-forms sub-forms (all :funobj) (all :env)) + (assert (not (minusp (- stack-displacement (- (length sub-forms) 2))))) (multiple-value-bind (stack-restore-code new-returns) - (make-compiled-stack-restore stack-displacement result-mode :multiple-values) - (declare (ignore stack-restore-code)) + (make-compiled-stack-restore (- stack-displacement + (- (length sub-forms) 2)) + result-mode + :multiple-values) (compiler-values () :returns new-returns :type `(values ,@arguments-types) @@ -1127,16 +1130,14 @@ (loop for i from (- (length sub-forms) 3) downto 0 collecting `(:locally (:popl (:edi (:edi-offset values ,(* i 4)))))) - (make-immediate-move (length sub-forms) :ecx) - `((:leal ((:ecx ,+movitz-fixnum-factor+) ,(* -2 +movitz-fixnum-factor+)) - :edx) - (:locally (:movl :edx (:edi (:edi-offset num-values)))) + (make-immediate-move (* +movitz-fixnum-factor+ (- (length sub-forms) 2)) + :ecx) + `((:locally (:movl :ecx (:edi (:edi-offset num-values)))) (:stc)) #+ignore (make-compiled-funcall-by-symbol 'muerte.cl::values (length sub-forms) (all :funobj)) - #+ignore stack-restore-code))))))))) (define-special-operator muerte::compiler-typecase (&all all &form form)

1 0

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

24 Apr '05

Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv21149 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Apr 24 23:59:59 2005 Author: ffjeld Index: public_html/ChangeLog diff -u public_html/ChangeLog:1.4 public_html/ChangeLog:1.5 --- public_html/ChangeLog:1.4 Mon Apr 18 08:44:49 2005 +++ public_html/ChangeLog Sun Apr 24 23:59:59 2005 @@ -1,3 +1,13 @@ +2005-04-24 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> + + * Fixed a bug in the compilation of (values ...) for more than two + values: the stack-pointer would not be reset properly, causing the + stack to grow very quickly in certain situations, such as when + such a values statement was executed inside a loop, which happens + e.g. in do-symbols & friends. This bug has gone undetected because + usually a stack-frame exit will occur after a values statement, + masking out any failures. + 2005-04-18 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> * Added support in the compiler for non-dynamic-extent &rest

1 0

[movitz-cvs] CVS update: movitz/procfs-image.lisp
by ffjeld＠common-lisp.net 24 Apr '05

24 Apr '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv16653 Modified Files: procfs-image.lisp Log Message: Some backtrace tweaks. Date: Sun Apr 24 22:36:44 2005 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.22 movitz/procfs-image.lisp:1.23 --- movitz/procfs-image.lisp:1.22 Tue Jan 4 17:56:44 2005 +++ movitz/procfs-image.lisp Sun Apr 24 22:36:44 2005 @@ -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.22 2005/01/04 16:56:44 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.23 2005/04/24 20:36:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -165,7 +165,8 @@ (get-word stack-frame)) (defun stack-frame-funobj (stack-frame) - (when (zerop (ldb (byte 2 0) stack-frame)) + (when (and (plusp stack-frame) + (zerop (ldb (byte 2 0) stack-frame))) (let ((x (movitz-word (get-word (- stack-frame 4))))) (and (typep x 'movitz-funobj) x)))) @@ -196,6 +197,7 @@ (image-register32 *image* :esi)) (let ((*print-length* 20)) (loop for stack-frame = (current-stack-frame) then (previous-stack-frame stack-frame) + while (plusp stack-frame) unless (zerop (mod stack-frame 4)) do (format t "[frame #x~8,'0x]" stack-frame) (loop-finish) @@ -228,7 +230,9 @@ (debug-get-object (get-word (+ stack-frame -12)) spartan))) (when print-returns (format t " (#x~X)" (stack-frame-return-address stack-frame))))) - (t (write (movitz-print movitz-name))))) + (t (when print-frames + (format t "~S " (truncate stack-frame 4))) + (write (movitz-print movitz-name))))) do (format t "~& => "))) (values))

1 0

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

24 Apr '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv3778 Modified Files: los0.lisp Log Message: Ensure there's a valid global binding for *package*. Date: Sun Apr 24 18:46:03 2005 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.39 movitz/losp/los0.lisp:1.40 --- movitz/losp/los0.lisp:1.39 Mon Apr 18 09:08:42 2005 +++ movitz/losp/los0.lisp Sun Apr 24 18:46:03 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.39 2005/04/18 07:08:42 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.40 2005/04/24 16:46:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1315,9 +1315,9 @@ :index (+ x (* y muerte.x86-pc::*screen-stride*)) :type :unsigned-byte16))) data))) - (muerte.ip4:tftp/ethernet-write :129.242.16.151 "movitz-screendump.txt" data + (muerte.ip4:tftp/ethernet-write :129.242.19.132 "movitz-screendump.txt" data :quiet t - :mac (muerte.ip4::polling-arp :129.242.16.1 + :mac (muerte.ip4::polling-arp ip4::*ip4-router* (lambda () (eql #\escape (muerte.x86-pc.keyboard:poll-char))))))) @@ -1332,6 +1332,21 @@ (defvar *segment-descriptor-table*) +(defun threading () + (let* ((thread (muerte::clone-run-time-context :name 'subthread)) + (stack (make-array 1022 :element-type '(unsigned-byte 32)))) + (setf (segment-descriptor *segment-descriptor-table* 8) + (segment-descriptor *segment-descriptor-table* (truncate (segment-register :fs) 8))) + (warn "Thread ~S FS base: ~S" + thread + (setf (segment-descriptor-base-location *segment-descriptor-table* 8) + (+ (object-location thread) + (muerte::location-physical-offset)))) + (format *terminal-io* "~&Switching...") + (setf (segment-register :fs) (* 8 8)) + (format *terminal-io* "ok.~%") + (values thread stack))) + (defun genesis () ;; (install-shallow-binding) (let ((extended-memsize 0)) @@ -1354,12 +1369,13 @@ (setf *debugger-function* #'los0-debugger) (clos-bootstrap) - (install-shallow-binding) + (setf *package* (find-package "INIT")) + ;; (install-shallow-binding) (let ((*repl-readline-context* (make-readline-context :history-size 16)) #+ignore (*backtrace-stack-frame-barrier* (stack-frame-uplink (current-stack-frame))) #+ignore (*error-no-condition-for-debugger* t) #+ignore (*debugger-function* #'los0-debugger) - (*package* nil)) + (*package* *package*)) (with-simple-restart (abort "Skip Los0 boot-up initialization.") (setf *cpu-features* (find-cpu-features))

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