Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7579 Modified Files: compiler.lisp image.lisp procfs-image.lisp special-operators-cl.lisp special-operators.lisp storage-types.lisp Log Message: many cleanup regarding stack and register discipline. Date: Wed Sep 15 12:22:52 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.98 movitz/compiler.lisp:1.99 --- movitz/compiler.lisp:1.98 Thu Sep 2 11:16:42 2004 +++ movitz/compiler.lisp Wed Sep 15 12:22:52 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.98 2004/09/02 09:16:42 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.99 2004/09/15 10:22:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2194,15 +2194,15 @@ (setq p (list i `(:pushl ,(twop-src i))) next-pc (nthcdr 2 pc)) (explain nil "store, push => store, push reg: ~S ~S" i i2)) - ((and (instruction-is i :cmpl) - (true-and-equal (stack-frame-operand (twop-dst i)) - (load-stack-frame-p i3)) - (branch-instruction-label i2)) - (setf p (list i3 - `(:cmpl ,(twop-src i) ,(twop-dst i3)) - i2) - next-pc (nthcdr 3 pc)) - (explain nil "~S ~S ~S => ~S" i i2 i3 p)) +;;; ((and (instruction-is i :cmpl) +;;; (true-and-equal (stack-frame-operand (twop-dst i)) +;;; (load-stack-frame-p i3)) +;;; (branch-instruction-label i2)) +;;; (setf p (list i3 +;;; `(:cmpl ,(twop-src i) ,(twop-dst i3)) +;;; i2) +;;; next-pc (nthcdr 3 pc)) +;;; (explain t "~S ~S ~S => ~S" i i2 i3 p)) ((and (instruction-is i :pushl) (instruction-is i3 :popl) (store-stack-frame-p i2) Index: movitz/image.lisp diff -u movitz/image.lisp:1.66 movitz/image.lisp:1.67 --- movitz/image.lisp:1.66 Thu Sep 2 11:21:14 2004 +++ movitz/image.lisp Wed Sep 15 12:22:52 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.66 2004/09/02 09:21:14 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.67 2004/09/15 10:22:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -290,12 +290,24 @@ :initform 0) (values :binary-type #.(* 4 +movitz-multiple-values-limit+)) - (malloc-pointer-words + (get-cons-pointer :binary-type code-vector-word + :initform nil :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) - (malloc-non-pointer-words + (cons-commit + :binary-type code-vector-word + :initform nil + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + (get-cons-pointer-non-pointer + :binary-type code-vector-word + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + (cons-commit-non-pointer :binary-type code-vector-word :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector @@ -438,11 +450,13 @@ (segment-descriptor-7 :binary-type segment-descriptor :initform (make-segment-descriptor)) - (scratch0 ; A non-GC-root scratch register + (raw-scratch0 ; A non-GC-root scratch register :binary-type lu32 :initform 0) (non-pointers-end :binary-type :label) ; ========= NON-POINTER-END ======= - + (scratch1 + :binary-type word + :initform 0) (atomically-status :binary-type (define-bitfield atomically-status (lu32) (((:enum :byte (3 2)) @@ -456,19 +470,7 @@ :initform '(:inactive)) (atomically-esp :binary-type lu32 - :initform 0) - (get-cons-pointer - :binary-type code-vector-word - :initform nil - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector - :binary-tag :primitive-function) - (cons-commit - :binary-type code-vector-word - :initform nil - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector - :binary-tag :primitive-function)) + :initform 0)) (:slot-align null-symbol -5)) (defun atomically-status-simple-pf (pf-name reset-status-p &rest registers) @@ -937,7 +939,7 @@ (assert (file-position stream 512) () ; leave room for bootblock. "Couldn't set file-position for ~W." (pathname stream)) (let* ((stack-vector (make-instance 'movitz-basic-vector - :num-elements #x2ffe + :num-elements #x3ffe :fill-pointer 0 :symbolic-data nil :element-type :u32)) Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.18 movitz/procfs-image.lisp:1.19 --- movitz/procfs-image.lisp:1.18 Mon Aug 30 16:59:23 2004 +++ movitz/procfs-image.lisp Wed Sep 15 12:22:52 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org> ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.18 2004/08/30 14:59:23 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.19 2004/09/15 10:22:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -196,6 +196,7 @@ (null (write-string "?") (let* ((eax (get-word (+ (* 4 (interrupt-frame-index :eax)) stack-frame))) + (ebx (get-word (+ (* 4 (interrupt-frame-index :ebx)) 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))) @@ -203,9 +204,9 @@ (esi (get-word (+ (* 4 (interrupt-frame-index :esi)) stack-frame))) (exception (get-word (+ (* 4 (interrupt-frame-index :exception-vector)) stack-frame)))) - (format t "#x~X {EAX: #x~X, ECX: #x~X, EDX: #x~X, EDI: #x~X, ESI: #x~X, EIP: #x~X, exception ~D}" + (format t "#x~X {EAX: #x~X, EBX: #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))) + eax ebx ecx edx edi esi eip exception))) (movitz-symbol (let ((name (movitz-print movitz-name))) (when print-frames Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.22 movitz/special-operators-cl.lisp:1.23 --- movitz/special-operators-cl.lisp:1.22 Thu Sep 2 11:27:32 2004 +++ movitz/special-operators-cl.lisp Wed Sep 15 12:22:52 2004 @@ -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.22 2004/09/02 09:27:32 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.23 2004/09/15 10:22:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1182,15 +1182,10 @@ `((:pushl :ebp) ; push stack frame (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) ; install catch body-code - `((:popl :ebp) ; This value is identical to current EBP. - ,exit-point - (:leal (:esp ,(+ -8 16)) :esp)) - (if (not *compiler-produce-defensive-code*) - `((:locally (:popl (:edi (:edi-offset dynamic-env))))) - `((:xchgl :ecx (:esp)) - (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx)) - (:locally (:movl :ecx (:edi (:edi-offset dynamic-env)))) - (:popl :ecx))))))) + `(,exit-point + (:popl :ebp) + (:leal (:esp 8) :esp) ; Skip catch-tag and jumper + (:locally (:popl (:edi (:edi-offset dynamic-env))))))))) (define-special-operator unwind-protect (&all all &form form &env env) (destructuring-bind (protected-form &body cleanup-forms) Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.37 movitz/special-operators.lisp:1.38 --- movitz/special-operators.lisp:1.37 Thu Sep 2 11:27:38 2004 +++ movitz/special-operators.lisp Wed Sep 15 12:22:52 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.37 2004/09/02 09:27:38 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.38 2004/09/15 10:22:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1199,16 +1199,23 @@ )))) ; save dynamic-slot in EBP ;; now outside of m-v-prog1's cloak, with final dynamic-slot in ESP.. ;; ..unwind it and transfer control. - `((:load-lexical ,dynamic-slot-binding :ebp) - (:leave) - (:movl (:ebp -4) :esi) - (:movl (:esp 4) :edx) - ;; (:halt) + ;; + ;; * 12 dynamic-env uplink + ;; * 8 target jumper number + ;; * 4 target catch tag + ;; * 0 target EBP +;;; `((:load-lexical ,dynamic-slot-binding :edx) +;;; ()) + `((:load-lexical ,dynamic-slot-binding :edx) + (:locally (:movl :esi (:edi (:edi-offset scratch1)))) + (:movl :edx :esp) ; enter non-local jump stack mode. + + (:movl (:esp) :edx) ; target stack-frame EBP + (:movl (:edx -4) :esi) ; get target funobj into EDX + + (:movl (:esp 8) :edx) ; target jumper number (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0)))))))))) -;;; (:leal (:esp 8) :esp) ; skip tag and eip -;;; (:locally (:popl (:edi (:edi-offset dynamic-env)))) ; unwind dynamic env -;;; (:jmp (:esp -8)))))))) (define-special-operator muerte::with-basic-restart (&all defaults &form form &env env) (destructuring-bind ((name function interactive test format-control @@ -1284,8 +1291,9 @@ :result-mode :multiple-values :with-stack-used entry-size :form body) - `((:leal (:esp ,(+ -12 (* 4 entry-size))) :esp) + `((:leal (:esp ,(+ -12 -4 (* 4 entry-size))) :esp) ,exit-point - (:leal (:esp ,(+ -8 16)) :esp) + (:popl :ebp) + (:leal (:esp 8) :esp) (:locally (:popl (:edi (:edi-offset dynamic-env)))) ))))))) Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.39 movitz/storage-types.lisp:1.40 --- movitz/storage-types.lisp:1.39 Thu Aug 19 00:32:53 2004 +++ movitz/storage-types.lisp Wed Sep 15 12:22:52 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.39 2004/08/18 22:32:53 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.40 2004/09/15 10:22:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -58,9 +58,14 @@ :odd-fixnum 4 :cons 1 :character 2 + :tag0 0 + :tag1 1 :tag2 2 :tag3 3 ; unused :tag4 4 + :tag5 5 + :tag6 6 + :tag7 7 ;; :immediate 4 :null 5 :other 6 @@ -72,7 +77,7 @@ :bignum #x4a :ratio #x52 :complex #x5a - :defstruct #x20 + :defstruct #x2a :std-instance #x40 :run-time-context #x50 :illegal #x13 @@ -1171,12 +1176,6 @@ (make-instance 'movitz-std-instance :class (movitz-read class) :slots slots)) - -;;;(defmethod write-binary-record ((obj movitz-std-instance) stream) -;;; (+ (write-binary 'word stream (movitz-intern (movitz-std-instance-class obj))) -;;; (let ((slots (movitz-read (movitz-std-instance-slots obj)))) -;;; (assert (typep slots 'movitz-vector)) -;;; (write-binary 'word stream (movitz-intern slots))))) (defmethod print-object ((object movitz-std-instance) stream) (print-unreadable-object (object stream :identity t)