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

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

23 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9358 Modified Files: more-macros.lisp Log Message: Added a macro without-interrupts. Date: Mon Aug 23 06:49:40 2004 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.17 movitz/losp/muerte/more-macros.lisp:1.18 --- movitz/losp/muerte/more-macros.lisp:1.17 Wed Jul 28 03:01:16 2004 +++ movitz/losp/muerte/more-macros.lisp Mon Aug 23 06:49:40 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.17 2004/07/28 10:01:16 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.18 2004/08/23 13:49:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -361,6 +361,13 @@ (:cld)) (do-case (t :multiple-values) (:compile-form (:result-mode :multiple-values) (no-macro-call read-time-stamp-counter))))) + +(defmacro without-interrupts (&body body) + (let ((var (gensym "interrupts-enabled-p-"))) + `(let ((,var (logbitp ,(position :if +eflags-map+) (eflags)))) + (unwind-protect (progn (cli) ,@body) + (when ,var (sti)))))) + ;;; Some macros that aren't implemented, and we want to give compiler errors.

1 0

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

23 Aug '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11169 Modified Files: procfs-image.lisp Log Message: Add a *print-lengt* value in procfs backtrace. Date: Mon Aug 23 06:46:19 2004 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.16 movitz/procfs-image.lisp:1.17 --- movitz/procfs-image.lisp:1.16 Mon Aug 16 01:25:28 2004 +++ movitz/procfs-image.lisp Mon Aug 23 06:46:18 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.16 2004/08/16 08:25:28 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.17 2004/08/23 13:46:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -187,39 +187,40 @@ ;; (search-image-funobj (image-register32 *image* :eip)) (format t "~&Current ESI: #x~X.~%" (image-register32 *image* :esi)) - (loop for stack-frame = (current-stack-frame) then (previous-stack-frame stack-frame) - unless (zerop (mod stack-frame 4)) - do (format t "[frame #x~8,'0x]" stack-frame) - (loop-finish) - do (let ((movitz-name (funobj-name (stack-frame-funobj stack-frame)))) - (typecase movitz-name - (null - (write-string "?") - (let* ((eax (get-word (+ (* 4 (interrupt-frame-index :eax)) stack-frame))) - (ecx (get-word (+ (* 4 (interrupt-frame-index :ecx)) stack-frame))) - (edx (get-word (+ (* 4 (interrupt-frame-index :edx)) stack-frame))) - (edi (get-word (+ (* 4 (interrupt-frame-index :edi)) stack-frame))) - (eip (get-word (+ (* 4 (interrupt-frame-index :eip)) stack-frame))) - (esi (get-word (+ (* 4 (interrupt-frame-index :esi)) stack-frame))) - (exception (get-word (+ (* 4 (interrupt-frame-index :exception)) stack-frame)))) - (format t "#x~X {EAX: #x~X, ECX: #x~X, EDX: #x~X, EDI: #x~X, ESI: #x~X, EIP: #x~X, exception ~D}" - stack-frame - eax ecx edx edi esi eip exception))) - (movitz-symbol - (let ((name (movitz-print movitz-name))) - (when print-frames - (format t "~S " stack-frame)) - (when (string= name 'toplevel-function) - (loop-finish)) - (when reqs - (format t "(~A ~S ~S)" - (symbol-name name) - (debug-get-object (get-word (+ stack-frame -8)) spartan) - (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))))) - do (format t "~& => ")) + (let ((*print-length* 20)) + (loop for stack-frame = (current-stack-frame) then (previous-stack-frame stack-frame) + unless (zerop (mod stack-frame 4)) + do (format t "[frame #x~8,'0x]" stack-frame) + (loop-finish) + do (let ((movitz-name (funobj-name (stack-frame-funobj stack-frame)))) + (typecase movitz-name + (null + (write-string "?") + (let* ((eax (get-word (+ (* 4 (interrupt-frame-index :eax)) stack-frame))) + (ecx (get-word (+ (* 4 (interrupt-frame-index :ecx)) stack-frame))) + (edx (get-word (+ (* 4 (interrupt-frame-index :edx)) stack-frame))) + (edi (get-word (+ (* 4 (interrupt-frame-index :edi)) stack-frame))) + (eip (get-word (+ (* 4 (interrupt-frame-index :eip)) stack-frame))) + (esi (get-word (+ (* 4 (interrupt-frame-index :esi)) stack-frame))) + (exception (get-word (+ (* 4 (interrupt-frame-index :exception)) stack-frame)))) + (format t "#x~X {EAX: #x~X, ECX: #x~X, EDX: #x~X, EDI: #x~X, ESI: #x~X, EIP: #x~X, exception ~D}" + stack-frame + eax ecx edx edi esi eip exception))) + (movitz-symbol + (let ((name (movitz-print movitz-name))) + (when print-frames + (format t "~S " stack-frame)) + (when (string= name 'toplevel-function) + (loop-finish)) + (when reqs + (format t "(~A ~S ~S)" + (symbol-name name) + (debug-get-object (get-word (+ stack-frame -8)) spartan) + (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))))) + do (format t "~& => "))) (values)) (defun funobj-name (x)

1 0

[movitz-cvs] CVS update: movitz/losp/tmp/partitions.lisp
by Frode Vatvedt Fjeld 19 Aug '04

19 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/tmp In directory common-lisp.net:/tmp/cvs-serv25413 Added Files: partitions.lisp Log Message: Added these files as submitted by Alessio Stalla. Date: Wed Aug 18 17:28:57 2004 Author: ffjeld

1 0

[movitz-cvs] CVS update: movitz/losp/tmp/fs.lisp
by Frode Vatvedt Fjeld 19 Aug '04

19 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/tmp In directory common-lisp.net:/tmp/cvs-serv22466 Added Files: fs.lisp Log Message: Added these files as submitted by Alessio Stalla. Date: Wed Aug 18 17:28:50 2004 Author: ffjeld

1 0

[movitz-cvs] CVS update: movitz/losp/tmp/ext2fs.lisp
by Frode Vatvedt Fjeld 19 Aug '04

19 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/tmp In directory common-lisp.net:/tmp/cvs-serv20256 Added Files: ext2fs.lisp Log Message: Added these files as submitted by Alessio Stalla. Date: Wed Aug 18 17:28:45 2004 Author: ffjeld

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by Frode Vatvedt Fjeld 19 Aug '04

19 Aug '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18611 Modified Files: compiler.lisp Log Message: Changed the compilation protocol for computing bindings "lended" status. Now, unused local functions should not impact bindings (previously even an unused local function would cause a binding to become "lended", ie. referenced indirectly). Date: Wed Aug 18 17:22:03 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.96 movitz/compiler.lisp:1.97 --- movitz/compiler.lisp:1.96 Wed Aug 18 15:30:51 2004 +++ movitz/compiler.lisp Wed Aug 18 17:22:02 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.96 2004/08/18 22:30:51 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.97 2004/08/19 00:22:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -561,8 +561,8 @@ ;;; (warn "binding ~S of ~S is not local to ~S, replacing with ~S of ~S." ;;; binding (binding-env binding) funobj ;;; borrowing-binding (binding-env borrowing-binding)) - (pushnew borrowing-binding - (getf (binding-lended-p binding) :lended-to)) +;;; (pushnew borrowing-binding +;;; (getf (binding-lended-p binding) :lended-to)) (dolist (usage usages) (pushnew usage (borrowed-binding-usage borrowing-binding))) borrowing-binding) @@ -650,6 +650,10 @@ (list :anonymous-lambda (movitz-funobj-name toplevel-funobj) (post-incf sub-funobj-index))))) + (loop for borrowed-binding in (borrowed-bindings sub-funobj) + do (pushnew borrowed-binding + (getf (binding-lending (borrowed-binding-target borrowed-binding)) + :lended-to))) (cond ((or (null usage) (null (borrowed-bindings sub-funobj))) @@ -788,7 +792,7 @@ optp-location req-location opt-location))) (make-stack-setup-code (- stack-frame-size stack-setup-pre)) (when (binding-lended-p req-binding) - (let ((lended-cons-position (getf (binding-lended-p req-binding) + (let ((lended-cons-position (getf (binding-lending req-binding) :stack-cons-location))) (etypecase req-location (integer @@ -2297,14 +2301,18 @@ :accessor macro-binding-expander))) (defclass variable-binding (binding) - ((lended-p ; a property-list + ((lending ; a property-list :initform nil - :accessor binding-lended-p) + :accessor binding-lending) (store-type ; union of all types ever stored here :initform nil ;; :initarg :store-type :accessor binding-store-type))) +(defmethod binding-lended-p ((binding variable-binding)) + (and (getf (binding-lending binding) :lended-to) + (not (eq :unused (getf (binding-lending binding) :lended-to))))) + (defclass lexical-binding (variable-binding) ()) (defclass located-binding (lexical-binding) ()) @@ -2807,7 +2815,7 @@ (pushnew lended-binding (potentially-lended-bindings function-env)) (take-note-of-binding lended-binding) - (symbol-macrolet ((p (binding-lended-p lended-binding))) + (symbol-macrolet ((p (binding-lending lended-binding))) (incf (getf p :lended-count 0)) (setf (getf p :dynamic-extent-p) (and (getf p :dynamic-extent-p t) dynamic-extent-p)))))) @@ -2962,7 +2970,7 @@ (dolist (binding bindings-register-goodness-sort) (unless (and (binding-lended-p binding) (not (typep binding 'borrowed-binding)) - (not (getf (binding-lended-p binding) :stack-cons-location))) + (not (getf (binding-lending binding) :stack-cons-location))) (unless (new-binding-located-p binding frame-map) (check-type binding located-binding) (multiple-value-bind (register status) @@ -3011,12 +3019,12 @@ (dolist (binding bindings-register-goodness-sort) (when (and (binding-lended-p binding) (not (typep binding 'borrowed-binding)) - (not (getf (binding-lended-p binding) :stack-cons-location))) + (not (getf (binding-lending binding) :stack-cons-location))) ;; (warn "assigning lending-cons for ~W at ~D" binding stack-frame-position) (let ((cons-pos (post-incf stack-frame-position 2))) (setf (new-binding-location (cons :lended-cons binding) frame-map) (1+ cons-pos)) - (setf (getf (binding-lended-p binding) :stack-cons-location) + (setf (getf (binding-lending binding) :stack-cons-location) cons-pos))) (unless (new-binding-located-p binding frame-map) (etypecase binding @@ -3551,18 +3559,18 @@ funobj lended-binding borrowing-binding) (assert (eq funobj (binding-funobj lended-binding))) - (assert (plusp (getf (binding-lended-p (actual-binding lended-binding)) + (assert (plusp (getf (binding-lending (actual-binding lended-binding)) :lended-count 0)) () "Asked to lend ~S of ~S to ~S of ~S with no lended-count." lended-binding (binding-env lended-binding) borrowing-binding (binding-env borrowing-binding)) (assert (eq funobj-register :edx)) - (when (getf (binding-lended-p lended-binding) :dynamic-extent-p) + (when (getf (binding-lending lended-binding) :dynamic-extent-p) (assert dynamic-extent-p)) ;; (warn "lending: ~W" lended-binding) (append (make-load-lexical lended-binding :eax funobj t frame-map) (unless (or (typep lended-binding 'borrowed-binding) - (getf (binding-lended-p lended-binding) :dynamic-extent-p)) + (getf (binding-lending lended-binding) :dynamic-extent-p)) (append `((:pushl :edx) (:globally (:call (:edi (:edi-offset ensure-heap-cons-variable)))) (:popl :edx)) @@ -4176,7 +4184,7 @@ `((:movl :edx (:ebp ,(stack-frame-offset (new-binding-location (edx-var env) frame-map)))))) eax-ebx-code-post-stackframe (loop for binding in (potentially-lended-bindings env) - as lended-cons-position = (getf (binding-lended-p binding) :stack-cons-location) + as lended-cons-position = (getf (binding-lending binding) :stack-cons-location) as location = (new-binding-location binding frame-map :default nil) when (and (not (typep binding 'borrowed-binding)) lended-cons-position @@ -6040,7 +6048,7 @@ )))) (cond ((binding-lended-p binding) - (let* ((cons-position (getf (binding-lended-p binding) + (let* ((cons-position (getf (binding-lending binding) :stack-cons-location)) (init-register (etypecase init-with-register (lexical-binding

1 0

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

18 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15328 Modified Files: interrupt.lisp Log Message: Some fixes regarding restarting functions from inside atomically. Date: Wed Aug 18 15:37:57 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.20 movitz/losp/muerte/interrupt.lisp:1.21 --- movitz/losp/muerte/interrupt.lisp:1.20 Thu Aug 12 09:57:15 2004 +++ movitz/losp/muerte/interrupt.lisp Wed Aug 18 15:37:56 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.20 2004/08/12 16:57:15 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.21 2004/08/18 22:37:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -239,9 +239,10 @@ (:movl :edi (:ebp 16)) (:movl :edi (:ebp 20)) (:movl (:ebp 0) :ebp) ; pop stack-frame + (:movl (:ebp -4) :esi) ; reset funobj in ESI (:locally (:movl (:edi (:edi-offset atomically-esp)) :esp)) ; restore ESP ;; XXXX this state isn't covered in the stack discipline!?! - (:jmp (:esi :ebx ,(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0))) + (:jmp (:esi :ebx (:offset movitz-funobj constant0))) atomically-jumper-return-dirty-registers ;; If the interruptee had DF set, then initialize all GP registers with @@ -264,7 +265,7 @@ (:movl (:ebp -4) :esi) (:locally (:movl (:edi (:edi-offset atomically-esp)) :esp)) ; restore ESP ;; XXXX this state isn't covered in the stack discipline!?! - (:jmp (:esi :ebx ,(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0))) + (:jmp (:esi :ebx (:offset movitz-funobj constant0))) not-simple-restart-jumper ;; Don't know what to do.

1 0

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

18 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6592 Modified Files: bignums.lisp Log Message: Fixed register usage in bignum-mulf, so as to observe register discipline. Date: Wed Aug 18 15:36:37 2004 Author: ffjeld Index: movitz/losp/muerte/bignums.lisp diff -u movitz/losp/muerte/bignums.lisp:1.5 movitz/losp/muerte/bignums.lisp:1.6 --- movitz/losp/muerte/bignums.lisp:1.5 Tue Jul 20 01:53:56 2004 +++ movitz/losp/muerte/bignums.lisp Wed Aug 18 15:36:37 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Jul 17 19:42:57 2004 ;;;; -;;;; $Id: bignums.lisp,v 1.5 2004/07/20 08:53:56 ffjeld Exp $ +;;;; $Id: bignums.lisp,v 1.6 2004/08/18 22:36:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -413,20 +413,20 @@ (:compile-form (:result-mode :ecx) factor) (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) - (:xorl :ecx :ecx) ; Counter + (:xorl :esi :esi) ; Counter (by 4) (:xorl :edx :edx) ; Initial carry - (:std) ; Make EAX, EDX, ESI non-GC-roots. + (:std) ; Make EAX, EDX non-GC-roots. multiply-loop - (:movl (:ebx :ecx (:offset movitz-bignum bigit0)) + (:movl (:ebx :esi (:offset movitz-bignum bigit0)) :eax) - (:movl :edx :esi) ; Save carry in ESI + (:movl :edx :ecx) ; Save carry in ECX (:locally (:mull (:edi (:edi-offset scratch0)) :eax :edx)) ; EDX:EAX = scratch0*EAX - (:addl :esi :eax) ; Add carry + (:addl :ecx :eax) ; Add carry (:adcl 0 :edx) ; Compute next carry (:jc '(:sub-program (should-not-happen) (:int 63))) - (:movl :eax (:ebx :ecx (:offset movitz-bignum bigit0))) - (:addl 4 :ecx) - (:cmpw :cx (:ebx (:offset movitz-bignum length))) + (:movl :eax (:ebx :esi (:offset movitz-bignum bigit0))) + (:addl 4 :esi) + (:cmpw :si (:ebx (:offset movitz-bignum length))) (:ja 'multiply-loop) (:movl (:ebp -4) :esi) (:movl :edx :ecx) ; Carry into ECX

1 0

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

18 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10977 Modified Files: basic-macros.lisp Log Message: Add an optional eax-form argument to halt-cpu. Date: Wed Aug 18 15:35:45 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.37 movitz/losp/muerte/basic-macros.lisp:1.38 --- movitz/losp/muerte/basic-macros.lisp:1.37 Sat Aug 14 10:53:25 2004 +++ movitz/losp/muerte/basic-macros.lisp Wed Aug 18 15:35:45 2004 @@ -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.37 2004/08/14 17:53:25 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.38 2004/08/18 22:35:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1013,9 +1013,11 @@ `(with-inline-assembly (:returns :untagged-fixnum-ecx) (:globally (:movl (:edi (:edi-offset ,name)) :ecx))))) -(define-compiler-macro halt-cpu () +(define-compiler-macro halt-cpu (&optional eax-form) (let ((infinite-loop-label (make-symbol "infinite-loop"))) `(with-inline-assembly (:returns :nothing) + ,@(when eax-form + `((:compile-form (:result-mode :eax) ,eax-form))) ,infinite-loop-label (:halt) (:jmp ',infinite-loop-label))))

1 0

[movitz-cvs] CVS update: movitz/storage-types.lisp
by Frode Vatvedt Fjeld 18 Aug '04

18 Aug '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv1409 Modified Files: storage-types.lisp Log Message: Add initform for funobj's extent slot. And a :fixnum tag. Date: Wed Aug 18 15:32:54 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.38 movitz/storage-types.lisp:1.39 --- movitz/storage-types.lisp:1.38 Tue Aug 10 06:25:21 2004 +++ movitz/storage-types.lisp Wed Aug 18 15:32:53 2004 @@ -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.38 2004/08/10 13:25:21 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.39 2004/08/18 22:32:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -53,6 +53,7 @@ (file-position (image-stream *image*) ,v))))) (define-enum other-type-byte (u8) + :fixnum 0 :even-fixnum 0 :odd-fixnum 4 :cons 1 @@ -757,6 +758,7 @@ :accessor funobj-env) (extent :initarg :extent + :initform :unused :accessor movitz-funobj-extent) (usage :initform nil @@ -1283,4 +1285,3 @@ (setf (slot-value obj 'numerator) (numerator value) (slot-value obj 'denominator) (denominator value)) (call-next-method))) - \ No newline at end of file

1 0