From ffjeld at common-lisp.net Sun Aug 1 00:37:22 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 31 Jul 2004 17:37:22 -0700 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11774 Modified Files: image.lisp Log Message: Added 'complicated-eql' that understands ratios. Also, now = is essentially the same as eql. Date: Sat Jul 31 17:37:22 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.59 movitz/image.lisp:1.60 --- movitz/image.lisp:1.59 Sat Jul 31 16:34:52 2004 +++ movitz/image.lisp Sat Jul 31 17:37:22 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.59 2004/07/31 23:34:52 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.60 2004/08/01 00:37:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -289,6 +289,12 @@ :binary-tag :primitive-function) (+ :initform 'muerte.cl:+ + :binary-type word + :binary-tag :global-function + :map-binary-write 'movitz-intern + :map-binary-read-delayed 'movitz-word) + (complicated-eql + :initform 'muerte::complicated-eql :binary-type word :binary-tag :global-function :map-binary-write 'movitz-intern From ffjeld at common-lisp.net Sun Aug 1 00:37:26 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 31 Jul 2004 17:37:26 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15555 Modified Files: basic-macros.lisp Log Message: Added 'complicated-eql' that understands ratios. Also, now = is essentially the same as eql. Date: Sat Jul 31 17:37:26 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.35 movitz/losp/muerte/basic-macros.lisp:1.36 --- movitz/losp/muerte/basic-macros.lisp:1.35 Wed Jul 28 18:24:45 2004 +++ movitz/losp/muerte/basic-macros.lisp Sat Jul 31 17:37:26 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.35 2004/07/29 01:24:45 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.36 2004/08/01 00:37:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -438,11 +438,15 @@ `(eql ,y ,x)) ((and (movitz:movitz-constantp x env) (not (typep (movitz:movitz-eval x env) - '(and integer (not fixnum))))) + '(and number (not fixnum))))) `(eq ',(movitz:movitz-eval x env) ,y)) - (t `(with-inline-assembly (:returns :boolean-zf=1) + (t `(with-inline-assembly (:returns :boolean-zf=1 :labels (eql-done)) (:compile-two-forms (:eax :ebx) ,x ,y) - (:call-global-pf fast-eql))))) + (:cmpl :eax :ebx) + (:je 'eql-done) + (:globally (:movl (:edi (:edi-offset complicated-eql)) :esi)) + (:call (:esi (:offset movitz-funobj code-vector%2op))) + eql-done)))) (define-compiler-macro values (&rest sub-forms) `(inline-values , at sub-forms)) From ffjeld at common-lisp.net Sun Aug 1 00:37:31 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 31 Jul 2004 17:37:31 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16477 Modified Files: integers.lisp Log Message: Added 'complicated-eql' that understands ratios. Also, now = is essentially the same as eql. Date: Sat Jul 31 17:37:31 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.89 movitz/losp/muerte/integers.lisp:1.90 --- movitz/losp/muerte/integers.lisp:1.89 Fri Jul 30 15:10:59 2004 +++ movitz/losp/muerte/integers.lisp Sat Jul 31 17:37:31 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.89 2004/07/30 22:10:59 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.90 2004/08/01 00:37:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -139,6 +139,57 @@ (:ret)))) (do-it))) +(defun complicated-eql (x y) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :multiple-values) ; well.. + (:compile-two-forms (:eax :ebx) x y) + (:cmpl :eax :ebx) ; EQ? + (:je 'done) + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jne 'done) + (:leal (:ebx ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jne 'done) + (:movl (:eax ,movitz:+other-type-offset+) :ecx) + (:cmpb ,(movitz:tag :bignum) :cl) + (:jne 'not-bignum) + (:cmpl :ecx (:ebx ,movitz:+other-type-offset+)) + (:jne 'done) + ;; Ok.. we have two bignums of identical sign and size. + (:shrl 16 :ecx) + (:movl :ecx :edx) ; counter + compare-loop + (:subl ,movitz:+movitz-fixnum-factor+ :edx) + (:jz 'done) + (:movl (:eax :edx (:offset movitz-bignum bigit0 -4)) :ecx) + (:cmpl :ecx (:ebx :edx (:offset movitz-bignum bigit0 -4))) + (:je 'compare-loop) + (:jmp 'done) + not-bignum + (:cmpb ,(movitz:tag :ratio) :cl) + (:jne 'not-ratio) + (:cmpl :ecx (:ebx ,movitz:+other-type-offset+)) + (:jne 'done) + (:movl (:eax (:offset movitz-ratio numerator)) :eax) + (:movl (:ebx (:offset movitz-ratio numerator)) :ebx) + (:call (:esi (:offset movitz-funobj code-vector%2op))) + (:jne 'done) + (:compile-two-forms (:eax :ebx) x y) + (:movl (:eax (:offset movitz-ratio denominator)) :eax) + (:movl (:ebx (:offset movitz-ratio denominator)) :ebx) + (:call (:esi (:offset movitz-funobj code-vector%2op))) + (:jmp 'done) + not-ratio + + done + (:movl :edi :eax) + (:clc) + ))) + (do-it))) + + (define-primitive-function fast-eql (x y) "Compare EAX and EBX under EQL, result in ZF. Preserve EAX and EBX." @@ -337,9 +388,7 @@ (:call-global-pf fast-compare-two-reals)))))) ((movitz:movitz-constantp n2 env) `(=%2op ,n2 ,n1)) - (t `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil) - (:compile-two-forms (:eax :ebx) ,n1 ,n2) - (:call-global-pf fast-compare-two-reals))))) + (t `(eql ,n1 ,n2)))) (define-number-relational = =%2op nil :defun-p nil) @@ -349,7 +398,10 @@ (unless (= first-number n) (return nil)))) -(define-number-relational /= /=%2op :boolean-zf=0 :defun-p nil) +(define-compiler-macro /=%2op (n1 n2) + `(not (= ,n1 ,n2))) + +(define-number-relational /= /=%2op nil :defun-p nil) (defun /= (&rest numbers) (declare (dynamic-extent numbers)) @@ -724,9 +776,9 @@ (:testb 7 :cl) (:jnz '(:sub-program (not-a-number) (:compile-form (:result-mode :ignore) - (if (ratio-p x) - (make-rational (- (ratio-numerator x)) - (ratio-denominator x)) + (if (typep x 'ratio) + (make-rational (- (%ratio-numerator x)) + (%ratio-denominator x)) (error 'type-error :expected-type 'number :datum x))))) (:movl (:eax ,movitz:+other-type-offset+) :ecx) (:cmpb ,(movitz:tag :bignum) :cl) @@ -1212,21 +1264,21 @@ (defun truncate (number &optional (divisor 1)) (numargs-case (1 (number) - (if (not (ratio-p number)) + (if (not (typep number 'ratio)) (values number 0) (multiple-value-bind (q r) - (truncate (ratio-numerator number) - (ratio-denominator number)) - (values q (make-rational r (ratio-denominator number)))))) + (truncate (%ratio-numerator number) + (%ratio-denominator number)) + (values q (make-rational r (%ratio-denominator number)))))) (t (number divisor) (number-double-dispatch (number divisor) ((t (eql 1)) - (if (not (ratio-p number)) + (if (not (typep number 'ratio)) (values number 0) (multiple-value-bind (q r) - (truncate (ratio-numerator number) - (ratio-denominator number)) - (values q (make-rational r (ratio-denominator number)))))) + (truncate (%ratio-numerator number) + (%ratio-denominator number)) + (values q (make-rational r (%ratio-denominator number)))))) ((fixnum fixnum) (with-inline-assembly (:returns :multiple-values) (:compile-form (:result-mode :eax) number) @@ -1414,10 +1466,10 @@ (defun / (number &rest denominators) (numargs-case (1 (x) - (if (not (ratio-p x)) + (if (not (typep x 'ratio)) (make-rational 1 x) - (make-rational (ratio-denominator x) - (ratio-numerator x)))) + (make-rational (%ratio-denominator x) + (%ratio-numerator x)))) (2 (x y) (multiple-value-bind (q r) (truncate x y) @@ -2172,11 +2224,11 @@ "This is floor written in terms of truncate." (numargs-case (1 (n) - (if (not (ratio-p n)) + (if (not (typep n 'ratio)) (values n 0) (multiple-value-bind (r q) - (floor (ratio-numerator n) (ratio-denominator n)) - (values r (make-rational q (ratio-denominator n)))))) + (floor (%ratio-numerator n) (%ratio-denominator n)) + (values r (%make-rational q (%ratio-denominator n)))))) (2 (n divisor) (multiple-value-bind (q r) (truncate n divisor) From lgorrie at common-lisp.net Mon Aug 2 07:45:31 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 02 Aug 2004 00:45:31 -0700 Subject: [movitz-cvs] CVS update: movitz/ide/ide.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/ide In directory common-lisp.net:/tmp/cvs-serv4281 Modified Files: ide.lisp Log Message: Fixed with-open-file args in `compile-defun'. Date: Mon Aug 2 00:45:31 2004 Author: lgorrie Index: movitz/ide/ide.lisp diff -u movitz/ide/ide.lisp:1.1 movitz/ide/ide.lisp:1.2 --- movitz/ide/ide.lisp:1.1 Wed Jul 21 03:54:42 2004 +++ movitz/ide/ide.lisp Mon Aug 2 00:45:30 2004 @@ -23,7 +23,8 @@ (defun compile-defun (source) "Compile the string SOURCE as Movitz source." - (with-open-file (s temp-source-file :direction :output :if-exists :overwrite) + (with-open-file (s temp-source-file :direction :output + :if-exists :overwrite :if-does-not-exist :create) (princ source s)) (compile-movitz-file temp-source-file)) From ffjeld at common-lisp.net Wed Aug 4 12:58:46 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 04 Aug 2004 05:58:46 -0700 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv19715 Modified Files: image.lisp Log Message: Slightly improved disassembly of primitive-functions. Date: Wed Aug 4 05:58:46 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.60 movitz/image.lisp:1.61 --- movitz/image.lisp:1.60 Sat Jul 31 17:37:22 2004 +++ movitz/image.lisp Wed Aug 4 05:58:45 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.60 2004/08/01 00:37:22 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.61 2004/08/04 12:58:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1288,12 +1288,12 @@ (slot-offset 'movitz-funobj 'constant0)) 4) (movitz-funobj-const-list funobj))) - when (and funobj (typep operand 'ia-x86::operand-rel-pointer)) + when (typep operand 'ia-x86::operand-rel-pointer) collect (let* ((x (+ pc (imagpart (ia-x86::instruction-original-datum instruction)) (length (ia-x86:instruction-prefixes instruction)) (ia-x86::operand-offset operand))) - (label (car (find x (movitz-funobj-symtab funobj) :key #'cdr)))) + (label (and funobj (car (find x (movitz-funobj-symtab funobj) :key #'cdr))))) (if label (format nil "branch to ~S at ~D" label x) (format nil "branch to ~D" x))) From ffjeld at common-lisp.net Wed Aug 4 12:59:18 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 04 Aug 2004 05:59:18 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arithmetic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8035 Modified Files: arithmetic-macros.lisp Log Message: Moved %ratio accessor compiler-macros to arithmetic-macros.lisp. Date: Wed Aug 4 05:59:18 2004 Author: ffjeld Index: movitz/losp/muerte/arithmetic-macros.lisp diff -u movitz/losp/muerte/arithmetic-macros.lisp:1.5 movitz/losp/muerte/arithmetic-macros.lisp:1.6 --- movitz/losp/muerte/arithmetic-macros.lisp:1.5 Fri Jul 23 08:35:23 2004 +++ movitz/losp/muerte/arithmetic-macros.lisp Wed Aug 4 05:59:18 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Jul 17 13:42:46 2004 ;;;; -;;;; $Id: arithmetic-macros.lisp,v 1.5 2004/07/23 15:35:23 ffjeld Exp $ +;;;; $Id: arithmetic-macros.lisp,v 1.6 2004/08/04 12:59:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -486,3 +486,10 @@ (:jnc 'done) (:addl ,movitz:+movitz-fixnum-factor+ :eax) done)) + +(define-compiler-macro %ratio-numerator (x) + `(memref ,x ,(bt:slot-offset 'movitz::movitz-ratio 'movitz::numerator) 0 :lisp)) + +(define-compiler-macro %ratio-denominator (x) + `(memref ,x ,(bt:slot-offset 'movitz::movitz-ratio 'movitz::denominator) 0 :lisp)) + From ffjeld at common-lisp.net Wed Aug 4 12:59:23 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 04 Aug 2004 05:59:23 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9154 Modified Files: integers.lisp Log Message: Moved %ratio accessor compiler-macros to arithmetic-macros.lisp. Date: Wed Aug 4 05:59:23 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.90 movitz/losp/muerte/integers.lisp:1.91 --- movitz/losp/muerte/integers.lisp:1.90 Sat Jul 31 17:37:31 2004 +++ movitz/losp/muerte/integers.lisp Wed Aug 4 05:59:23 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.90 2004/08/01 00:37:31 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.91 2004/08/04 12:59:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2228,7 +2228,7 @@ (values n 0) (multiple-value-bind (r q) (floor (%ratio-numerator n) (%ratio-denominator n)) - (values r (%make-rational q (%ratio-denominator n)))))) + (values r (make-rational q (%ratio-denominator n)))))) (2 (n divisor) (multiple-value-bind (q r) (truncate n divisor) From ffjeld at common-lisp.net Wed Aug 4 13:00:33 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 04 Aug 2004 06:00:33 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8704 Modified Files: primitive-functions.lisp Log Message: Removed some dead debugging code. Date: Wed Aug 4 06:00:33 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.36 movitz/losp/muerte/primitive-functions.lisp:1.37 --- movitz/losp/muerte/primitive-functions.lisp:1.36 Sat Jul 31 16:35:03 2004 +++ movitz/losp/muerte/primitive-functions.lisp Wed Aug 4 06:00:33 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.36 2004/07/31 23:35:03 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.37 2004/08/04 13:00:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -430,7 +430,6 @@ (:leal (:ebx :ecx) :edx) ; new roof to EDX (:cmpl :edx (:eax)) ; end of buffer? (:jl '(:sub-program (failed) - (:movl (:eax) :esi) (:int 112) (:halt) (:jmp 'failed))) @@ -455,7 +454,6 @@ (:leal (:ebx :ecx) :edx) ; new roof to EDX (:cmpl :edx (:eax)) ; end of buffer? (:jl '(:sub-program (failed) - (:movl (:eax) :esi) (:int 112) (:halt) (:jmp 'failed))) From ffjeld at common-lisp.net Wed Aug 4 13:01:14 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 04 Aug 2004 06:01:14 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/ratios.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25249 Modified Files: ratios.lisp Log Message: Err.. this is from where the %ratio accessor compiler-macros were moved. Date: Wed Aug 4 06:01:14 2004 Author: ffjeld Index: movitz/losp/muerte/ratios.lisp diff -u movitz/losp/muerte/ratios.lisp:1.5 movitz/losp/muerte/ratios.lisp:1.6 --- movitz/losp/muerte/ratios.lisp:1.5 Sat Jul 31 16:35:09 2004 +++ movitz/losp/muerte/ratios.lisp Wed Aug 4 06:01:14 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Jul 20 00:39:59 2004 ;;;; -;;;; $Id: ratios.lisp,v 1.5 2004/07/31 23:35:09 ffjeld Exp $ +;;;; $Id: ratios.lisp,v 1.6 2004/08/04 13:01:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -39,15 +39,9 @@ (defun ratio-p (x) (typep x 'ratio)) -(define-compiler-macro %ratio-numerator (x) - `(memref ,x ,(bt:slot-offset 'movitz::movitz-ratio 'movitz::numerator) 0 :lisp)) - (defun ratio-numerator (x) (check-type x ratio) (%ratio-numerator x)) - -(define-compiler-macro %ratio-denominator (x) - `(memref ,x ,(bt:slot-offset 'movitz::movitz-ratio 'movitz::denominator) 0 :lisp)) (defun ratio-denominator (x) (check-type x ratio) From ffjeld at common-lisp.net Fri Aug 6 14:41:38 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 06 Aug 2004 07:41:38 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18113 Modified Files: compiler.lisp Log Message: Two substantial changes: Firstly the code for allocating &rest-lists on the stack is rewritten, because the old one didn't observe the stack discipline (causing weird bugs while experimenting with hw interrupts). Secondly, there was a bug/omission when lending optional-function-argument bindings to sub-functions, i.e like this: (defun foo (x &optional (y 0)) (lambda () (+ x (incf y)))) The code for foo in this case would be completely bogus, and e.g. over-write (car NIL) and generally ruin everyting. Date: Fri Aug 6 07:41:37 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.87 movitz/compiler.lisp:1.88 --- movitz/compiler.lisp:1.87 Wed Jul 28 17:12:54 2004 +++ movitz/compiler.lisp Fri Aug 6 07:41:37 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.87 2004/07/29 00:12:54 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.88 2004/08/06 14:41:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3404,7 +3404,7 @@ `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location))) (:jne ',(operands result-mode))) (ecase (operator binding-location) - ((:eax :ebx) + ((:eax :ebx :edx) `((:cmpl :edi ,binding-location) (:jne ',(operands result-mode)))) (:argument-stack @@ -3415,7 +3415,7 @@ `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location))) (:je ',(operands result-mode))) (ecase (operator binding-location) - ((:eax :ebx) + ((:eax :ebx :edx) `((:cmpl :edi ,binding-location) (:je ',(operands result-mode)))) (:argument-stack @@ -4264,6 +4264,10 @@ (function-argument-argnum binding))) unless (movitz-env-get optional-var 'ignore nil env nil) append + `((:init-lexvar ,binding)) + when supplied-p-binding + append `((:init-lexvar ,supplied-p-binding)) + append (compiler-values-bind (&code init-code-edx &producer producer) (compiler-call #'compile-form :form (optional-function-argument-init-form binding) @@ -4379,7 +4383,7 @@ (append #+ignore (make-immediate-move rest-position :edx) `(#+ignore (:call (:edi ,(global-constant-offset 'restify-dynamic-extent))) (:init-lexvar ,rest-binding - :init-with-register :eax + :init-with-register :edx :init-with-type list))))) (cond ;; &key processing.. @@ -5942,7 +5946,7 @@ (append (cond ((typep binding 'rest-function-argument) - (assert (eq :eax init-with-register)) + (assert (eq :edx init-with-register)) (assert (or (typep binding 'hidden-rest-function-argument) (movitz-env-get (binding-name binding) 'dynamic-extent nil (binding-env binding))) @@ -5951,13 +5955,47 @@ (setf (need-normalized-ecx-p (find-function-env (binding-env binding) funobj)) t) - (append (make-immediate-move (function-argument-argnum binding) :edx) - `((:call (:edi ,(global-constant-offset 'restify-dynamic-extent)))) - #+ignore - (unless (or (typep binding 'hidden-rest-function-argument) - (movitz-env-get (binding-name binding) - 'dynamic-extent nil (binding-env binding))) - (make-compiled-funcall-by-symbol 'muerte.cl:copy-list 1 funobj))))) + (let ((restify-alloca-loop (gensym "alloca-loop-")) + (restify-done (gensym "restify-done-")) + (restify-at-one (gensym "restify-at-one-")) + (restify-loop (gensym "restify-loop-"))) + (append + ;; (make-immediate-move (function-argument-argnum binding) :edx) + ;; `((:call (:edi ,(global-constant-offset 'restify-dynamic-extent)))) + ;; Make space for (1+ (* 2 (- ECX rest-pos))) words on the stack. + ;; Factor two is for one cons-cell per word, 1 is for 8-byte alignment. + `((:movl :edi :edx) + (:subl ,(function-argument-argnum binding) :ecx) + (:jbe ',restify-done) + (:leal ((:ecx 8) 4) :edx) ; EDX is fixnum counter + ,restify-alloca-loop + (:pushl :edi) + (:subl 4 :edx) + (:jnz ',restify-alloca-loop) + (:leal (:esp 5) :edx) + (:andl -7 :edx)) ; Make EDX a proper consp into the alloca area. + (cond + ((= 0 (function-argument-argnum binding)) + `((:movl :eax (:edx -1)) + (:movl :edx :eax) + (:subl 1 :ecx) + (:jz ',restify-done) + (:addl 8 :eax) + (:movl :eax (:eax -5)))) + (t `((:movl :edx :eax)))) + (when (>= 1 (function-argument-argnum binding)) + `((:jmp ',restify-at-one))) + `(,restify-loop + (:movl (:ebp (:ecx 4) 4) :ebx) + ,restify-at-one + (:movl :ebx (:eax -1)) + (:subl 1 :ecx) + (:jz ',restify-done) + (:addl 8 :eax) + (:movl :eax (:eax -5)) + (:jmp ',restify-loop) + ,restify-done) + )))) (cond ((binding-lended-p binding) (let* ((cons-position (getf (binding-lended-p binding) From ffjeld at common-lisp.net Fri Aug 6 14:43:46 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 06 Aug 2004 07:43:46 -0700 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12407 Modified Files: image.lisp Log Message: Mostly minor tweaks to the movitz-image structures.. ie. some naming changes etc. Date: Fri Aug 6 07:43:46 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.61 movitz/image.lisp:1.62 --- movitz/image.lisp:1.61 Wed Aug 4 05:58:45 2004 +++ movitz/image.lisp Fri Aug 6 07:43:46 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.61 2004/08/04 12:58:45 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.62 2004/08/06 14:43:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -324,14 +324,6 @@ :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) -;;; (malloc-buffer -;;; :binary-type lu32 -;;; :initform 0) - (default-interrupt-trampoline - :map-binary-write 'movitz-intern-code-vector - :binary-tag :primitive-function - :map-binary-read-delayed 'movitz-word-code-vector - :binary-type code-vector-word) (classes ; A vector of class meta-objects. :initform nil ; The first element is the map of corresponding names :binary-type word @@ -355,12 +347,19 @@ (movitz-read-and-intern (funcall 'muerte::movitz-find-class x) 'word)) :map-binary-read-delayed 'movitz-word) - (interrupt-handlers + (exception-handlers :binary-type word :map-binary-write 'movitz-intern :map-binary-read-delayed 'movitz-word - :initarg :interrupt-handlers - :accessor movitz-run-time-context-interrupt-handlers) + :initarg :exception-handlers + :accessor movitz-run-time-context-exception-handlers) + (exception-handler-tails + :binary-type word + :initform nil + :map-binary-write 'movitz-read-and-intern + :map-binary-read-delayed 'movitz-word + :initarg :exception-handler-tails + :accessor movitz-run-time-context-exception-handler-tails) (interrupt-descriptor-table :binary-type word :accessor movitz-run-time-context-interrupt-descriptor-table @@ -538,7 +537,7 @@ :t-symbol (movitz-read 't) :null-symbol *movitz-nil*)) -(defclass image () +(defclass movitz-image () ((ds-segment-base :initform #x100000 :accessor image-ds-segment-base) @@ -546,7 +545,7 @@ :initform #x100000 :accessor image-cs-segment-base))) -(defclass symbolic-image (image) +(defclass symbolic-image (movitz-image) ((object-hash :accessor image-object-hash) ; object => address (address-hash @@ -861,7 +860,7 @@ (setf (movitz-symbol-value (movitz-read 'muerte:*build-number*)) (1+ *bootblock-build*)) (let ((handler (movitz-env-symbol-function 'muerte::interrupt-default-handler))) - (setf (movitz-run-time-context-interrupt-handlers (image-run-time-context *image*)) + (setf (movitz-run-time-context-exception-handlers (image-run-time-context *image*)) (movitz-read (make-array 256 :initial-element handler)))) (let ((load-address (image-start-address *image*))) (setf (image-cons-pointer *image*) (- load-address @@ -964,7 +963,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 #x1ffe + :num-elements #x2ffe :fill-pointer 0 :symbolic-data nil :element-type :u32)) @@ -1587,6 +1586,7 @@ (movitz-fixnum (movitz-fixnum-value expr)) (movitz-std-instance expr) + (movitz-struct expr) (movitz-heap-object (or (image-movitz-to-lisp-object *image* expr) (error "Unknown Movitz object: ~S" expr))))) From ffjeld at common-lisp.net Fri Aug 6 14:43:51 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 06 Aug 2004 07:43:51 -0700 Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv13634 Modified Files: procfs-image.lisp Log Message: Mostly minor tweaks to the movitz-image structures.. ie. some naming changes etc. Date: Fri Aug 6 07:43:51 2004 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.13 movitz/procfs-image.lisp:1.14 --- movitz/procfs-image.lisp:1.13 Wed Jul 28 17:00:59 2004 +++ movitz/procfs-image.lisp Fri Aug 6 07:43:51 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.13 2004/07/29 00:00:59 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.14 2004/08/06 14:43:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -195,15 +195,16 @@ (typecase movitz-name (null (write-string "?") - (let* ((r (stack-frame-return-address stack-frame)) - (eax (get-word (+ (* 4 (interrupt-frame-index :eax)) stack-frame))) + (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)))) - (when r (format t "#x~X (ret #x~X {EAX: #x~X, ECX: #x~X, EDI: #x~X, EIP: #x~X, exception ~D})" - stack-frame - r eax ecx edi eip exception)))) + (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 From ffjeld at common-lisp.net Fri Aug 6 14:43:55 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 06 Aug 2004 07:43:55 -0700 Subject: [movitz-cvs] CVS update: movitz/stream-image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv14784 Modified Files: stream-image.lisp Log Message: Mostly minor tweaks to the movitz-image structures.. ie. some naming changes etc. Date: Fri Aug 6 07:43:55 2004 Author: ffjeld Index: movitz/stream-image.lisp diff -u movitz/stream-image.lisp:1.10 movitz/stream-image.lisp:1.11 --- movitz/stream-image.lisp:1.10 Wed Jul 28 03:00:59 2004 +++ movitz/stream-image.lisp Fri Aug 6 07:43:55 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Aug 27 14:46:50 2001 ;;;; -;;;; $Id: stream-image.lisp,v 1.10 2004/07/28 10:00:59 ffjeld Exp $ +;;;; $Id: stream-image.lisp,v 1.11 2004/08/06 14:43:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,7 +18,7 @@ (in-package movitz) -(defclass stream-image (image) +(defclass stream-image (movitz-image) ((stream :reader image-stream :initarg :stream) @@ -36,7 +36,10 @@ (progn (format *query-io* "~&Please enter the stream-images NIL value: ") (read *query-io*))) - :reader image-nil-word))) + :reader image-nil-word) + (nil-object + :initform (make-movitz-nil) + :reader image-nil-object))) (defmethod image-register32 ((image stream-image) register-name) (declare (ignorable image) (ignore register-name)) @@ -64,14 +67,7 @@ (:character (make-instance 'movitz-character :char (code-char (ldb (byte 8 8) word)))) (:null - #+ignore - (assert (= (- word (tag :null)) (image-run-time-context-address image)) (word) - "The word #x~8,'0X has NIL tag but isn't NIL." word) - (setf (image-stream-position image) 0 #+ignore (- word (tag :null))) - (let ((object (read-binary 'movitz-run-time-context (image-stream image)))) - (setf (movitz-heap-object-word (movitz-run-time-context-null-symbol object)) - word) - object)) + (image-nil-object image)) (:symbol ;; (warn "loading new symbol at ~S" word) (setf (image-stream-position image) From ffjeld at common-lisp.net Fri Aug 6 14:45:30 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 06 Aug 2004 07:45:30 -0700 Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11652 Modified Files: special-operators.lisp Log Message: Don't barf when compiling + forms whose value is ignored, i.e. like (progn (+ a b) nil) Date: Fri Aug 6 07:45:30 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.33 movitz/special-operators.lisp:1.34 --- movitz/special-operators.lisp:1.33 Wed Jul 28 03:00:45 2004 +++ movitz/special-operators.lisp Fri Aug 6 07:45:30 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.33 2004/07/28 10:00:45 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.34 2004/08/06 14:45:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1029,13 +1029,17 @@ (define-special-operator muerte::++%2op (&all all &form form &env env &result-mode result-mode) (destructuring-bind (term1 term2) (cdr form) - (let ((returns (ecase (result-mode-type result-mode) - ((:function :multiple-values :eax :push) :eax) - ((:ebx :ecx :edx) result-mode) - ((:lexical-binding) result-mode)))) - (compiler-values () - :returns returns - :code `((:add ,(movitz-binding term1 env) ,(movitz-binding term2 env) ,returns)))))) + (if (eq :ignore result-mode) + (compiler-call #'compile-form-unprotected + :forward all + :form `(muerte.cl:progn term1 term2)) + (let ((returns (ecase (result-mode-type result-mode) + ((:function :multiple-values :eax :push) :eax) + ((:ebx :ecx :edx) result-mode) + ((:lexical-binding) result-mode)))) + (compiler-values () + :returns returns + :code `((:add ,(movitz-binding term1 env) ,(movitz-binding term2 env) ,returns))))))) (define-special-operator muerte::include (&form form) (let ((*require-dependency-chain* From ffjeld at common-lisp.net Fri Aug 6 14:46:07 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 06 Aug 2004 07:46:07 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cons.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23008 Modified Files: cons.lisp Log Message: Minor docstring edit. Date: Fri Aug 6 07:46:07 2004 Author: ffjeld Index: movitz/losp/muerte/cons.lisp diff -u movitz/losp/muerte/cons.lisp:1.6 movitz/losp/muerte/cons.lisp:1.7 --- movitz/losp/muerte/cons.lisp:1.6 Wed Jul 21 18:02:15 2004 +++ movitz/losp/muerte/cons.lisp Fri Aug 6 07:46:06 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 15:25:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: cons.lisp,v 1.6 2004/07/22 01:02:15 ffjeld Exp $ +;;;; $Id: cons.lisp,v 1.7 2004/08/06 14:46:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -19,7 +19,7 @@ (in-package muerte) (define-primitive-function fast-cdr-car (cell) - "Compute both the car and the cdr of a cell." + "Compute both the car (into EBX) and the cdr (into EAX) of a cell." (with-inline-assembly (:returns :eax) (:leal (:eax -1) :ecx) (:testb 3 :cl) From ffjeld at common-lisp.net Fri Aug 6 14:46:45 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 06 Aug 2004 07:46:45 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30685 Modified Files: memref.lisp Log Message: Implemented (setf memref-int) for type :unsigned-byte32. Date: Fri Aug 6 07:46:45 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.22 movitz/losp/muerte/memref.lisp:1.23 --- movitz/losp/muerte/memref.lisp:1.22 Fri Jul 23 18:28:27 2004 +++ movitz/losp/muerte/memref.lisp Fri Aug 6 07:46:45 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.22 2004/07/24 01:28:27 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.23 2004/08/06 14:46:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -722,6 +722,26 @@ (let* ((physicalp (movitz::eval-form physicalp env)) (prefixes (if physicalp '(:gs-override) ()))) (ecase type + (:unsigned-byte32 + (assert (= 4 movitz:+movitz-fixnum-factor+)) + (if (not (movitz:movitz-constantp offset env)) + form + (let ((offset (movitz:movitz-eval offset env)) + (addr-var (gensym "memref-int-address-")) + (value-var (gensym "memref-int-value-"))) + `(let ((,value-var ,value) + (,addr-var (+ ,address ,index))) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-form (:result-mode :untagged-fixnum-ecx) ,addr-var) + (:testb ,(logior movitz:+movitz-fixnum-zmask+ + (* 3 movitz:+movitz-fixnum-factor+)) + :cl) + (:jnz '(:sub-program () (:int 70))) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) ; a fixnum (zerop (mod x 4)) shifted + (:pushl :ecx) ; ..twice left is still a fixnum! + (:compile-form (:result-mode :untagged-fixnum-ecx) ,value-var) + (:popl :eax) + (:movl :ecx (:eax ,offset))))))) (:lisp (assert (= 4 movitz:+movitz-fixnum-factor+)) `(with-inline-assembly (:returns :untagged-fixnum-eax) From ffjeld at common-lisp.net Fri Aug 6 14:47:41 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 06 Aug 2004 07:47:41 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv14784 Modified Files: debugger.lisp Log Message: Minor tweak to backtrace. Date: Fri Aug 6 07:47:41 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.19 movitz/losp/x86-pc/debugger.lisp:1.20 --- movitz/losp/x86-pc/debugger.lisp:1.19 Fri Jul 23 18:29:06 2004 +++ movitz/losp/x86-pc/debugger.lisp Fri Aug 6 07:47:41 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.19 2004/07/24 01:29:06 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.20 2004/08/06 14:47:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -450,7 +450,8 @@ (loop with conflate-count = 0 with count = 0 for stack-frame = initial-stack-frame then (let ((uplink (stack-frame-uplink stack-frame))) - (assert (> uplink stack-frame)) + (assert (> uplink stack-frame) () + "Backtracing uplink ~S from frame ~S." uplink stack-frame) uplink) as funobj = (stack-frame-funobj stack-frame t) do (flet ((print-leadin (stack-frame count conflate-count) From ffjeld at common-lisp.net Fri Aug 6 20:54:17 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 06 Aug 2004 13:54:17 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18883 Modified Files: primitive-functions.lisp Log Message: Removed some dead code. Date: Fri Aug 6 13:54:17 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.37 movitz/losp/muerte/primitive-functions.lisp:1.38 --- movitz/losp/muerte/primitive-functions.lisp:1.37 Wed Aug 4 06:00:33 2004 +++ movitz/losp/muerte/primitive-functions.lisp Fri Aug 6 13:54:17 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.37 2004/08/04 13:00:33 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.38 2004/08/06 20:54:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -296,122 +296,6 @@ search-failed (:ret))) ; success: ZF=0, eax=value -(define-primitive-function resolve-key-args (pos) - "" - ;; 1. Match each provided argument. - (with-inline-assembly (:returns :multiple-values) - (:leal (:ebp (:ecx 4) -4) :edx) - (:movl (:edx) :eax) - - - )) - - -;;;(define-primitive-function trampoline-restify-dynamic-extent-at0%2op () -;;; "Process &rest at position 0 in lambda-list, when 2 args are provided (ECX=2 is implied). -;;;EAX: arg0, EBX: arg1, Returns list in EAX and 2 in ECX. -;;;This is a special case of restify-dynamic-extent." -;;; (with-inline-assembly (:returns :nothing) -;;; (:popl :edx) ; return address -;;; (:pushl :edi) -;;; (:popl :edi) -;;; (:andl -8 :esp) -;;; (:pushl :ebx) ; cadr -;;; (:pushl :edi) ; cddr -;;; (:pushl :eax) ; car -;;; (:movl :esp :eax) -;;; (:subl 7 :eax) -;;; (:pushl :eax) -;;; (:addl 8 :eax) -;;; (:movl 2 :ecx) -;;; (:ret))) - - -(define-primitive-function restify-dynamic-extent () - "Process &rest. -EAX: arg0, EBX: arg1, ECX: numargs, EDX: rest-position, -EBP: stack-frame with rest of arguments, as per calling conventions. -Returns list in EAX and preserves numargs in ECX." - (with-inline-assembly (:returns :nothing) - (:cmpl :edx :ecx) - (:jle '(:sub-program () - (:movl :edi :eax) (:ret))) ; no rest at all. - - ;; Pop the return address into (:esp -8) and (:esp -12). - (:popl (:esp -8)) - (:subl 4 :esp) - (:popl (:esp -12)) - - (:pushl :edi) - (:popl :edi) - ;; Now the stack (below) looks like this: - ;; (:esp 0) = ??? - ;; (:esp -4) = EDI - ;; (:esp -8) = Return address - ;; (:esp -12) = Return address - - (:andl -8 :esp) ; align stack to 8 (subtracts 4 when required) - - ;; We now know the return address is in (:esp -8). - - (:testl :edx :edx) - (:jnz 'rest-pos-not-zero) ; arg0 doesn't go into rest. - - (:pushl :esp) ; cdr - (:subl 15 (:esp)) - - (:subl 4 :esp) - (:popl (:esp -12)) ; keep return address in (:esp -8) - - (:pushl :eax) ; car = eax - - (:movl :esp :eax) - (:incl :eax) ; store head of list in eax. - - (:incl :edx) - (:cmpl :edx :ecx) - (:je '(:sub-program (done-early) - (:movl :edi (:esp 4)) ; terminate list - (:movl (:esp -8) :ebx) ; load return address into ebx - (:jmp :ebx))) ; return - (:jmp 'rest-pos-was-zero) - - rest-pos-not-zero - (:leal (:esp -7) :eax) ; store head of list in eax. - - rest-pos-was-zero - (:cmpl 1 :edx) - (:jnz 'rest-pos-not-one-or-zero) - - (:pushl :esp) - (:subl 15 (:esp)) ; cdr - - (:subl 4 :esp) - (:popl (:esp -12)) ; keep return address in (:esp -8) - - (:pushl :ebx) ; car = ebx - - (:incl :edx) - (:cmpl :edx :ecx) - (:je 'done-early) - - rest-pos-not-one-or-zero - - (:movl (:esp -8) :ebx) ; load return address into ebx - (:negl :edx) - (:addl :ecx :edx) ; edx = (- ecx edx) - - loop - (:pushl :esp) - (:subl 15 (:esp)) ; cdr - (:pushl (:ebp (:edx 4) 4)) ; car = next arg - (:decl :edx) - (:jnz 'loop) - - done - - (:movl :edi (:esp 4)) ; terminate list - (:jmp :ebx))) ; return (define-primitive-function malloc-pointer-words () "Stupid allocator.. Number of words in EAX/fixnum. From ffjeld at common-lisp.net Sat Aug 7 11:10:19 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 07 Aug 2004 04:10:19 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv13722 Modified Files: compiler.lisp Log Message: When *compiler-auto-stack-checks-p* is true, perform check also after allocating an &rest-list on the stack. Date: Sat Aug 7 04:10:19 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.88 movitz/compiler.lisp:1.89 --- movitz/compiler.lisp:1.88 Fri Aug 6 07:41:37 2004 +++ movitz/compiler.lisp Sat Aug 7 04:10:19 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.88 2004/08/06 14:41:37 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.89 2004/08/07 11:10:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5972,6 +5972,9 @@ (:pushl :edi) (:subl 4 :edx) (:jnz ',restify-alloca-loop) + ,@(when *compiler-auto-stack-checks-p* + `((,*compiler-local-segment-prefix* + :bound (:edi ,(global-constant-offset 'stack-bottom)) :esp))) (:leal (:esp 5) :edx) (:andl -7 :edx)) ; Make EDX a proper consp into the alloca area. (cond From ffjeld at common-lisp.net Sat Aug 7 11:12:09 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 07 Aug 2004 04:12:09 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv21194 Modified Files: primitive-functions.lisp Log Message: Started work on having the pf's comply with the stack and register disciplines. Date: Sat Aug 7 04:12:09 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.38 movitz/losp/muerte/primitive-functions.lisp:1.39 --- movitz/losp/muerte/primitive-functions.lisp:1.38 Fri Aug 6 13:54:17 2004 +++ movitz/losp/muerte/primitive-functions.lisp Sat Aug 7 04:12:09 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.38 2004/08/06 20:54:17 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.39 2004/08/07 11:12:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -308,7 +308,7 @@ (:int 110) (:halt) (:jmp 'not-initialized))) - (:addl 7 :ebx) + (:addl 4 :ebx) (:andb #xf8 :bl) (:movl (:eax 4) :ecx) ; cons pointer to ECX (:leal (:ebx :ecx) :edx) ; new roof to EDX @@ -353,7 +353,7 @@ (check-type words (integer 2 *)) (compiler-macro-call malloc-non-pointer-words words)) -(define-primitive-function muerte::get-cons-pointer () +(define-primitive-function get-cons-pointer () "Return in EAX the next object location with space for EAX words, with tag 6. Preserve ECX." (macrolet @@ -361,9 +361,14 @@ ;; Here we just call malloc, and don't care if the allocation ;; is never comitted. `(with-inline-assembly (:returns :multiple-values) + ;; We need a stack-frame sice we're using the stack + (:pushl :ebp) + (:movl :esp :ebp) + (:pushl 4) (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) (:call-local-pf malloc-pointer-words) (:locally (:movl (:edi (:edi-offset scratch0)) :ecx)) + (:leave) (:ret)))) (do-it))) From ffjeld at common-lisp.net Mon Aug 9 13:38:21 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Aug 2004 06:38:21 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv13376 Modified Files: compiler.lisp Log Message: Be more restrictive about when to allow not setting up a stack-frame for a function. Use EDX rather than ECX for temporary holding the value of optional-p in 1req1opt prelude. Make the optimizer also optimize e.g. (:pushl (:ebp -8)) into (:pushl :eax) at the start of functions, not just similar :movl instructions. Date: Mon Aug 9 06:38:20 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.89 movitz/compiler.lisp:1.90 --- movitz/compiler.lisp:1.89 Sat Aug 7 04:10:19 2004 +++ movitz/compiler.lisp Mon Aug 9 06:38:20 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.89 2004/08/07 11:10:19 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.90 2004/08/09 13:38:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -715,10 +715,7 @@ (stack-frame-size (frame-map-size (frame-map function-env))) (use-stack-frame-p (or (plusp stack-frame-size) (tree-search resolved-code - '(:ebp :esp :call :leave)))) - (optional-stack-frame-p (tree-search resolved-optional-code - '(:ebp :esp :call :leave)))) - (assert (not optional-stack-frame-p)) + '(:pushl :popl :ebp :esp :call :leave))))) (let* ((function-code (let* ((req-binding (movitz-binding (first (required-vars function-env)) function-env nil)) @@ -735,13 +732,13 @@ (unless (eql nil opt-location) resolved-optional-code) (when optp-location - `((:movl :edi :ecx) - (:jmp 'optp-into-ecx-ok))) + `((:movl :edi :edx) + (:jmp 'optp-into-edx-ok))) '(entry%2op) (when optp-location `((,*compiler-global-segment-prefix* - :movl (:edi ,(global-constant-offset 't-symbol)) :ecx) - optp-into-ecx-ok)) + :movl (:edi ,(global-constant-offset 't-symbol)) :edx) + optp-into-edx-ok)) (when use-stack-frame-p +enter-stack-frame-code+) '(start-stack-frame-setup) @@ -769,7 +766,7 @@ ()) ((= optp-location (1+ stack-setup-pre)) (incf stack-setup-pre 1) - `((:pushl :ecx))) + `((:pushl :edx))) (t (error "Can't deal with optional-p at ~S, after (~S ~S)." optp-location req-location opt-location))) (make-stack-setup-code (- stack-frame-size stack-setup-pre)) @@ -1824,6 +1821,16 @@ (explain nil "load ~S already in ~S." i old-reg) `(:movl ,old-reg ,(twop-dst i)))) + ((and (instruction-is i :pushl) + (stack-frame-operand (idst i)) + (assoc (stack-frame-operand (idst i)) + frame-map)) + (let ((old-reg + (cdr (assoc (stack-frame-operand (idst i)) + frame-map)))) + (explain nil "push ~S already in ~S." + i old-reg) + `(:pushl ,old-reg))) (t i)))) (unless (eq new-i i) (setf mod-p t)) From ffjeld at common-lisp.net Mon Aug 9 13:38:55 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Aug 2004 06:38:55 -0700 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24944 Modified Files: image.lisp Log Message: Remove restify-dynamic-extent from run-time-context. Date: Mon Aug 9 06:38:55 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.62 movitz/image.lisp:1.63 --- movitz/image.lisp:1.62 Fri Aug 6 07:43:46 2004 +++ movitz/image.lisp Mon Aug 9 06:38:54 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.62 2004/08/06 14:43:46 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.63 2004/08/09 13:38:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -224,11 +224,6 @@ :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function :binary-type code-vector-word) - (restify-dynamic-extent - :binary-type code-vector-word - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector - :binary-tag :primitive-function) (box-u32-ecx :binary-type code-vector-word :map-binary-write 'movitz-intern-code-vector From ffjeld at common-lisp.net Mon Aug 9 14:39:32 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Aug 2004 07:39:32 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30432 Modified Files: compiler.lisp Log Message: Added variable *compiler-physical-segment-prefix*, similar to *compiler-local-segment-prefix* etc. Date: Mon Aug 9 07:39:31 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.90 movitz/compiler.lisp:1.91 --- movitz/compiler.lisp:1.90 Mon Aug 9 06:38:20 2004 +++ movitz/compiler.lisp Mon Aug 9 07:39:31 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.90 2004/08/09 13:38:20 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.91 2004/08/09 14:39:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -43,6 +43,10 @@ (defvar *compiler-global-segment-prefix* nil "Use these assembly-instruction prefixes when accessing the global run-time context.") + +(defvar *compiler-physical-segment-prefix* '(:gs-override) + "Use this instruction prefix when accessing a physical memory location +(i.e. typically some memory-mapped hardware device).") (defvar *compiler-allow-untagged-word-bits* 0 "Allow (temporary) untagged values of this bit-size to exist, because From ffjeld at common-lisp.net Mon Aug 9 14:39:37 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Aug 2004 07:39:37 -0700 Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv31425 Modified Files: packages.lisp Log Message: Added variable *compiler-physical-segment-prefix*, similar to *compiler-local-segment-prefix* etc. Date: Mon Aug 9 07:39:37 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.34 movitz/packages.lisp:1.35 --- movitz/packages.lisp:1.34 Tue Jul 20 05:39:16 2004 +++ movitz/packages.lisp Mon Aug 9 07:39:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.34 2004/07/20 12:39:16 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.35 2004/08/09 14:39:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1366,6 +1366,7 @@ #:*compiler-auto-stack-checks-p* #:*compiler-local-segment-prefix* #:*compiler-global-segment-prefix* + #:*compiler-physical-segment-prefix* #:*compiler-compile-eval-whens* #:*compiler-compile-macro-expanders* #:*compiler-allow-untagged-word-bits* From ffjeld at common-lisp.net Mon Aug 9 14:39:41 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Aug 2004 07:39:41 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv576 Modified Files: memref.lisp Log Message: Added variable *compiler-physical-segment-prefix*, similar to *compiler-local-segment-prefix* etc. Date: Mon Aug 9 07:39:41 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.23 movitz/losp/muerte/memref.lisp:1.24 --- movitz/losp/muerte/memref.lisp:1.23 Fri Aug 6 07:46:45 2004 +++ movitz/losp/muerte/memref.lisp Mon Aug 9 07:39:41 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.23 2004/08/06 14:46:45 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.24 2004/08/09 14:39:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -628,7 +628,9 @@ (not (movitz:movitz-constantp physicalp env))) form (let* ((physicalp (movitz::eval-form physicalp env)) - (prefixes (if physicalp '(:gs-override) ()))) + (prefixes (if (not physicalp) + () + movitz:*compiler-physical-segment-prefix*))) (ecase (movitz::eval-form type) (:lisp `(with-inline-assembly (:returns :eax) @@ -720,7 +722,9 @@ (warn "setf memref-int form: ~S, ~S ~S" form type physicalp) form) (let* ((physicalp (movitz::eval-form physicalp env)) - (prefixes (if physicalp '(:gs-override) ()))) + (prefixes (if (not physicalp) + () + movitz:*compiler-physical-segment-prefix*))) (ecase type (:unsigned-byte32 (assert (= 4 movitz:+movitz-fixnum-factor+)) From ffjeld at common-lisp.net Mon Aug 9 14:39:46 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Aug 2004 07:39:46 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/textmode.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv1195 Modified Files: textmode.lisp Log Message: Added variable *compiler-physical-segment-prefix*, similar to *compiler-local-segment-prefix* etc. Date: Mon Aug 9 07:39:46 2004 Author: ffjeld Index: movitz/losp/x86-pc/textmode.lisp diff -u movitz/losp/x86-pc/textmode.lisp:1.9 movitz/losp/x86-pc/textmode.lisp:1.10 --- movitz/losp/x86-pc/textmode.lisp:1.9 Thu Jul 29 05:48:35 2004 +++ movitz/losp/x86-pc/textmode.lisp Mon Aug 9 07:39:46 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 9 15:38:56 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: textmode.lisp,v 1.9 2004/07/29 12:48:35 ffjeld Exp $ +;;;; $Id: textmode.lisp,v 1.10 2004/08/09 14:39:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -116,8 +116,8 @@ (:shrl 1 :ebx) (:jz 'end-copy-loop) copy-loop - ((:gs-override) :movl (:eax :ebx -4) :ecx) - ((:gs-override) :movl :ecx (:edx :ebx -4)) + (#.movitz:*compiler-physical-segment-prefix* :movl (:eax :ebx -4) :ecx) + (#.movitz:*compiler-physical-segment-prefix* :movl :ecx (:edx :ebx -4)) (:subl 4 :ebx) (:ja 'copy-loop) end-copy-loop @@ -180,26 +180,27 @@ (:shrl #.movitz:+movitz-fixnum-shift+ :ebx) (:movb 2 :cl) - ((:gs-override) :movl #x07000700 (:ebx 0)) - ((:gs-override) :movl #x07000700 (:ebx 4)) - ((:gs-override) :movl #x07000700 (:ebx 8)) - ((:gs-override) :movl #x07000700 (:ebx 12)) + (,movitz:*compiler-physical-segment-prefix* + :movl #x07000700 (:ebx 0)) + (,movitz:*compiler-physical-segment-prefix* :movl #x07000700 (:ebx 4)) + (,movitz:*compiler-physical-segment-prefix* :movl #x07000700 (:ebx 8)) + (,movitz:*compiler-physical-segment-prefix* :movl #x07000700 (:ebx 12)) ,loop-label (:andl #x0f0f0f0f :eax) (:addl #x30303030 :eax) (:cmpb #x39 :al) (:jle ',l1) (:addb 7 :al) - ,l1 ((:gs-override) :movb :al (14 :ebx)) ; 8 + ,l1 (,movitz:*compiler-physical-segment-prefix* :movb :al (14 :ebx)) ; 8 (:cmpb #x39 :ah) (:jle ',l2) (:addb 7 :ah) - ,l2 ((:gs-override) :movb :ah (10 :ebx)) ; 6 + ,l2 (,movitz:*compiler-physical-segment-prefix* :movb :ah (10 :ebx)) ; 6 (:shrl 16 :eax) (:cmpb #x39 :al) (:jle ',l3) (:addb 7 :al) - ,l3 ((:gs-override) :movb :al (6 :ebx)) ; 4 + ,l3 (,movitz:*compiler-physical-segment-prefix* :movb :al (6 :ebx)) ; 4 (:cmpb #x39 :ah) (:jle ',l4) (:addb 7 :ah) - ,l4 ((:gs-override) :movb :ah (2 :ebx)) ; 2 + ,l4 (,movitz:*compiler-physical-segment-prefix* :movb :ah (2 :ebx)) ; 2 (:movl :edx :eax) (:shrl 4 :eax) From ffjeld at common-lisp.net Tue Aug 10 10:12:53 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 10 Aug 2004 03:12:53 -0700 Subject: [movitz-cvs] CVS update: ia-x86/proglist.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv19437 Modified Files: proglist.lisp Log Message: Support integer labels. Date: Tue Aug 10 03:12:53 2004 Author: ffjeld Index: ia-x86/proglist.lisp diff -u ia-x86/proglist.lisp:1.3 ia-x86/proglist.lisp:1.4 --- ia-x86/proglist.lisp:1.3 Mon Feb 9 16:04:04 2004 +++ ia-x86/proglist.lisp Tue Aug 10 03:12:52 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon May 15 13:43:55 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: proglist.lisp,v 1.3 2004/02/10 00:04:04 ffjeld Exp $ +;;;; $Id: proglist.lisp,v 1.4 2004/08/10 10:12:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -182,7 +182,7 @@ (loop for expr-rest on prog-list do (let ((expr (first expr-rest))) (etypecase expr - (SYMBOL + ((or SYMBOL integer) (setf (assemble-env-symtab env) (symtab-def-label (assemble-env-symtab env) expr From ffjeld at common-lisp.net Tue Aug 10 10:12:57 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 10 Aug 2004 03:12:57 -0700 Subject: [movitz-cvs] CVS update: ia-x86/read.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv23378 Modified Files: read.lisp Log Message: Support integer labels. Date: Tue Aug 10 03:12:57 2004 Author: ffjeld Index: ia-x86/read.lisp diff -u ia-x86/read.lisp:1.5 ia-x86/read.lisp:1.6 --- ia-x86/read.lisp:1.5 Mon Jun 21 00:33:50 2004 +++ ia-x86/read.lisp Tue Aug 10 03:12:57 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jul 31 13:54:27 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: read.lisp,v 1.5 2004/06/21 07:33:50 ffjeld Exp $ +;;;; $Id: read.lisp,v 1.6 2004/08/10 10:12:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -269,7 +269,7 @@ (loop for expr in program if (null expr) do (error "Illegal NIL expr in program: ~S" program) - else if (symbolp expr) + else if (or (symbolp expr) (integerp expr)) collect expr ; a label, collect it. else if (inline-data-p expr) collect (read-inline-data expr) ; inline data, read it. From ffjeld at common-lisp.net Tue Aug 10 12:56:13 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 10 Aug 2004 05:56:13 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10403 Modified Files: compiler.lisp Log Message: Added variables *compiler-nonlocal-lispval-read-segment-prefix* and *compiler-nonlocal-lispval-write-segment-prefix*, which are the instruction prefixes the compiler should add when writing (potential) pointer values to (potentially) nonlocal cells. Also, changed make-compiled-primitive to also return the code-vectors symtab. Date: Tue Aug 10 05:56:12 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.91 movitz/compiler.lisp:1.92 --- movitz/compiler.lisp:1.91 Mon Aug 9 07:39:31 2004 +++ movitz/compiler.lisp Tue Aug 10 05:56:12 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.91 2004/08/09 14:39:31 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.92 2004/08/10 12:56:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -45,8 +45,15 @@ run-time context.") (defvar *compiler-physical-segment-prefix* '(:gs-override) - "Use this instruction prefix when accessing a physical memory location -(i.e. typically some memory-mapped hardware device).") + "Use this instruction prefix when accessing a physical memory location (i.e. typically some memory-mapped hardware device).") + +(defvar *compiler-nonlocal-lispval-read-segment-prefix* '(:fs-override) + "Use this segment prefix when reading a lispval at (potentially) +non-local locations.") + +(defvar *compiler-nonlocal-lispval-write-segment-prefix* '(:fs-override) + "Use this segment prefix when writing a lispval at (potentially) +non-local locations.") (defvar *compiler-allow-untagged-word-bits* 0 "Allow (temporary) untagged values of this bit-size to exist, because @@ -102,18 +109,20 @@ :result-mode :ignore)) ;; (ignmore (format t "~{~S~%~}" body-code)) (resolved-code (finalize-code body-code nil nil)) - (function-code (ia-x86:read-proglist resolved-code)) - (code-vector (ia-x86:proglist-encode :octet-vector - :32-bit - #x00000000 - function-code - :symtab-lookup - #'(lambda (label) - (case label - (:nil-value (image-nil-word *image*))))))) - (make-movitz-vector (length code-vector) - :element-type 'code - :initial-contents code-vector))) + (function-code (ia-x86:read-proglist resolved-code))) + (multiple-value-bind (code-vector symtab) + (ia-x86:proglist-encode :octet-vector + :32-bit + #x00000000 + function-code + :symtab-lookup + #'(lambda (label) + (case label + (:nil-value (image-nil-word *image*))))) + (values (make-movitz-vector (length code-vector) + :element-type 'code + :initial-contents code-vector) + symtab)))) (defun register-function-code-size (funobj) (let* ((name (movitz-print (movitz-funobj-name funobj))) From ffjeld at common-lisp.net Tue Aug 10 12:58:23 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 10 Aug 2004 05:58:23 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29984/losp/muerte Modified Files: arrays.lisp Log Message: Add some support for *compiler-nonlocal-lispval-{read,write}-segment-prefix*. Date: Tue Aug 10 05:58:23 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.41 movitz/losp/muerte/arrays.lisp:1.42 --- movitz/losp/muerte/arrays.lisp:1.41 Tue Jul 27 06:46:39 2004 +++ movitz/losp/muerte/arrays.lisp Tue Aug 10 05:58:22 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.41 2004/07/27 13:46:39 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.42 2004/08/10 12:58:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -309,7 +309,8 @@ (:addl ,movitz:+movitz-fixnum-factor+ :eax) (:jmp 'return) :any-t - (:movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)) + (,movitz:*compiler-nonlocal-lispval-read-segment-prefix* + :movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)) :eax) return))) (do-it))))) @@ -346,7 +347,8 @@ ;; t? (:cmpl ,(movitz:basic-vector-type-tag :any-t) :ecx) (:jne 'not-any-t-vector) - (:movl :eax + (,movitz:*compiler-nonlocal-lispval-write-segment-prefix* + :movl :eax (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) (:jmp 'return) @@ -433,6 +435,7 @@ `(setf (memref ,simple-vector 2 ,index :lisp) ,value)) (defun svref%unsafe (simple-vector index) +;; (compiler-macro-call svref%unsafe simple-vector index)) (with-inline-assembly (:returns :eax) (:compile-two-forms (:eax :ebx) simple-vector index) (:movl (:eax :ebx #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)) :eax))) From ffjeld at common-lisp.net Tue Aug 10 12:58:28 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 10 Aug 2004 05:58:28 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv32225/losp/muerte Modified Files: memref.lisp Log Message: Add some support for *compiler-nonlocal-lispval-{read,write}-segment-prefix*. Date: Tue Aug 10 05:58:28 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.24 movitz/losp/muerte/memref.lisp:1.25 --- movitz/losp/muerte/memref.lisp:1.24 Mon Aug 9 07:39:41 2004 +++ movitz/losp/muerte/memref.lisp Tue Aug 10 05:58:28 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.24 2004/08/09 14:39:41 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.25 2004/08/10 12:58:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,8 +18,10 @@ (in-package muerte) -(define-compiler-macro memref (&whole form object offset index type &environment env) - (if (not (movitz:movitz-constantp type env)) +(define-compiler-macro memref (&whole form object offset index type &key (localp nil) + &environment env) + (if (or (not (movitz:movitz-constantp type env)) + (not (movitz:movitz-constantp localp env))) form (labels ((sub-extract-constant-delta (form) "Try to extract at compile-time an integer offset from form." @@ -220,32 +222,36 @@ (:addl :ebx :ecx) (:movl (:eax :ecx ,(offset-by 4)) :ecx))))))) (:lisp - (cond - ((and (eql 0 index) (eql 0 offset)) - `(with-inline-assembly (:returns :register) - (:compile-form (:result-mode :register) ,object) - (:movl ((:result-register) ,(offset-by 4)) (:result-register)))) - ((eql 0 offset) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ecx) ,object ,index) - ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) - `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx)) - (:movl (:eax :ecx ,(offset-by 4)) :eax))) - ((eql 0 index) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object ,offset) - (:movl (:eax :ecx ,(offset-by 4)) :eax))) - (t (assert (not (movitz:movitz-constantp offset env))) - (assert (not (movitz:movitz-constantp index env))) - (let ((object-var (gensym "memref-object-"))) - (assert (= 4 movitz:+movitz-fixnum-factor+)) - `(let ((,object-var ,object)) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:ecx :ebx) ,offset ,index) - (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) - (:load-lexical (:lexical-binding ,object-var) :eax) - (:addl :ebx :ecx) - (:movl (:eax :ecx ,(offset-by 4)) :eax))))))) + (let* ((localp (movitz:movitz-eval localp env)) + (prefixes (if localp + nil + movitz:*compiler-nonlocal-lispval-read-segment-prefix*))) + (cond + ((and (eql 0 index) (eql 0 offset)) + `(with-inline-assembly (:returns :register) + (:compile-form (:result-mode :register) ,object) + (,prefixes :movl ((:result-register) ,(offset-by 4)) (:result-register)))) + ((eql 0 offset) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) ,object ,index) + ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) + `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx)) + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :eax))) + ((eql 0 index) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object ,offset) + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :eax))) + (t (assert (not (movitz:movitz-constantp offset env))) + (assert (not (movitz:movitz-constantp index env))) + (let ((object-var (gensym "memref-object-"))) + (assert (= 4 movitz:+movitz-fixnum-factor+)) + `(let ((,object-var ,object)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :eax) + (:addl :ebx :ecx) + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :eax)))))))) (:code-vector ;; A code-vector is like a normal lisp word pointer, ;; except it's known to point to a code-vector, and @@ -297,8 +303,10 @@ (:signed-byte30+2 (memref object offset index :signed-byte30+2)) (:unsigned-byte29+3 (memref object offset index :unsigned-byte29+3)))) -(define-compiler-macro (setf memref) (&whole form &environment env value object offset index type) - (if (not (movitz:movitz-constantp type env)) +(define-compiler-macro (setf memref) (&whole form &environment env value object offset index type + &key (localp nil)) + (if (or (not (movitz:movitz-constantp type env)) + (not (movitz:movitz-constantp localp env))) form (case (movitz::eval-form type) (:character @@ -544,33 +552,37 @@ (:movb :ah (:ebx :ecx))) ,value-var))))) (:lisp - (cond - ((and (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ebx) ,value ,object) - (:movl :eax (:ebx ,(+ (movitz:movitz-eval offset env) - (* 4 (movitz:movitz-eval index env))))))) - ((movitz:movitz-constantp offset env) - (let ((value-var (gensym "memref-value-"))) - `(let ((,value-var ,value)) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:ebx :ecx) ,object ,index) - (:load-lexical (:lexical-binding ,value-var) :eax) - ,@(when (plusp (- movitz:+movitz-fixnum-shift+ 2)) - `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx)) - (:movl :eax (:ebx :ecx ,(movitz:movitz-eval offset env))))))) - (t (let ((value-var (gensym "memref-value-")) - (object-var (gensym "memref-object-"))) - `(let ((,value-var ,value) (,object-var ,object)) + (let* ((localp (movitz:movitz-eval localp env)) + (prefixes (if localp + nil + movitz:*compiler-nonlocal-lispval-write-segment-prefix*))) + (cond + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) ,value ,object) + (,prefixes :movl :eax (:ebx ,(+ (movitz:movitz-eval offset env) + (* 4 (movitz:movitz-eval index env))))))) + ((movitz:movitz-constantp offset env) + (let ((value-var (gensym "memref-value-"))) + `(let ((,value-var ,value)) (with-inline-assembly (:returns :eax) - (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,offset ,index) + (:compile-two-forms (:ebx :ecx) ,object ,index) (:load-lexical (:lexical-binding ,value-var) :eax) - ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) - `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx)) - (:addl :ebx :ecx) ; index += offset - (:load-lexical (:lexical-binding ,object-var) :ebx) - (:movl :eax (:ebx :ecx)))))))) + ,@(when (plusp (- movitz:+movitz-fixnum-shift+ 2)) + `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx)) + (,prefixes :movl :eax (:ebx :ecx ,(movitz:movitz-eval offset env))))))) + (t (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-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) + ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) + `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx)) + (:addl :ebx :ecx) ; index += offset + (:load-lexical (:lexical-binding ,object-var) :ebx) + (,prefixes :movl :eax (:ebx :ecx))))))))) (:code-vector (cond ((and (movitz:movitz-constantp offset env) From ffjeld at common-lisp.net Tue Aug 10 12:59:36 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 10 Aug 2004 05:59:36 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv20610 Modified Files: interrupt.lisp Log Message: Remove dead macro end-of-interrupt. Date: Tue Aug 10 05:59:36 2004 Author: ffjeld Index: movitz/losp/x86-pc/interrupt.lisp diff -u movitz/losp/x86-pc/interrupt.lisp:1.9 movitz/losp/x86-pc/interrupt.lisp:1.10 --- movitz/losp/x86-pc/interrupt.lisp:1.9 Tue Apr 6 17:12:28 2004 +++ movitz/losp/x86-pc/interrupt.lisp Tue Aug 10 05:59:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri May 4 18:08:50 2001 ;;;; -;;;; $Id: interrupt.lisp,v 1.9 2004/04/07 00:12:28 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.10 2004/08/10 12:59:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,11 +18,6 @@ (provide :x86-pc/interrupt) (in-package muerte.x86-pc) - -(defmacro end-of-interrupt () - '(with-inline-assembly (:returns :nothing) - (:movb #x20 :al) - (:outb :al #x20))) (defun idt-init () (init-pic8259 32 40) From ffjeld at common-lisp.net Tue Aug 10 13:03:08 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 10 Aug 2004 06:03:08 -0700 Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv27328 Modified Files: packages.lisp Log Message: More symbols. Date: Tue Aug 10 06:03:06 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.35 movitz/packages.lisp:1.36 --- movitz/packages.lisp:1.35 Mon Aug 9 07:39:36 2004 +++ movitz/packages.lisp Tue Aug 10 06:03:06 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.35 2004/08/09 14:39:36 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.36 2004/08/10 13:03:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1367,6 +1367,8 @@ #:*compiler-local-segment-prefix* #:*compiler-global-segment-prefix* #:*compiler-physical-segment-prefix* + #:*compiler-nonlocal-lispval-read-segment-prefix* + #:*compiler-nonlocal-lispval-write-segment-prefix* #:*compiler-compile-eval-whens* #:*compiler-compile-macro-expanders* #:*compiler-allow-untagged-word-bits* From ffjeld at common-lisp.net Tue Aug 10 13:25:16 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 10 Aug 2004 06:25:16 -0700 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv16978 Modified Files: image.lisp Log Message: Changed the way the interrupt-descriptor-table is generated. Now, the host/build-time value is a vector whose elements are names of primitive-functions that act as interrupt trampolines. Each such trampoline (ie. at present only muerte:default-interrupt-trampoline) at position x in the table must define an (integer) assembly-level label x, which will become the entry-point of that interrupt-gate. Date: Tue Aug 10 06:25:16 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.63 movitz/image.lisp:1.64 --- movitz/image.lisp:1.63 Mon Aug 9 06:38:54 2004 +++ movitz/image.lisp Tue Aug 10 06:25:16 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.63 2004/08/09 13:38:54 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.64 2004/08/10 13:25:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -358,9 +358,9 @@ (interrupt-descriptor-table :binary-type word :accessor movitz-run-time-context-interrupt-descriptor-table - :initarg :interrupt-descriptor-table + :initform (make-array 256 :initial-element 'muerte::default-interrupt-trampoline) :map-binary-read-delayed 'movitz-word - :map-binary-write 'map-idt-to-array) + :map-binary-write 'map-interrupt-trampolines-to-idt) (toplevel-funobj :binary-type word :initform nil @@ -813,8 +813,6 @@ 'segment-descriptor-table)) 16)) (warn "Segment descriptor table is not aligned on a 16-byte boundary.")) - (setf (movitz-run-time-context-interrupt-descriptor-table (image-run-time-context *image*)) - (movitz-read (make-initial-interrupt-descriptors))) (setf (image-t-symbol *image*) (movitz-read t)) ;; (warn "NIL value: #x~X" (image-nil-word *image*)) *image*)) From ffjeld at common-lisp.net Tue Aug 10 13:25:22 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 10 Aug 2004 06:25:22 -0700 Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv19168 Modified Files: storage-types.lisp Log Message: Changed the way the interrupt-descriptor-table is generated. Now, the host/build-time value is a vector whose elements are names of primitive-functions that act as interrupt trampolines. Each such trampoline (ie. at present only muerte:default-interrupt-trampoline) at position x in the table must define an (integer) assembly-level label x, which will become the entry-point of that interrupt-gate. Date: Tue Aug 10 06:25:21 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.37 movitz/storage-types.lisp:1.38 --- movitz/storage-types.lisp:1.37 Sat Jul 31 16:34:57 2004 +++ movitz/storage-types.lisp Tue Aug 10 06:25:21 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.37 2004/07/31 23:34:57 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.38 2004/08/10 13:25:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1112,33 +1112,25 @@ type 'segment-present))) -(defconstant +idt-size+ 127) -(defconstant +idt-irq-start+ 32) - -(defun make-initial-interrupt-descriptors () - (make-array - +idt-size+ - :initial-element nil)) - -(defun map-idt-to-array (idt type) - (check-type idt movitz-basic-vector) +(defun map-interrupt-trampolines-to-idt (trampolines type) + (check-type trampolines vector) (assert (eq type 'word)) - (let ((byte-list - (with-binary-output-to-list (bytes) - (loop for descriptor across (movitz-vector-symbolic-data idt) - as i upfrom 0 - if (not (eq *movitz-nil* descriptor)) - do (write-binary-record descriptor bytes) - else - do (write-binary-record - (make-gate-descriptor ':interrupt - (+ (slot-offset 'movitz-basic-vector 'data) - (movitz-intern - (find-primitive-function - 'muerte::default-interrupt-trampoline)) - (* 10 i)) - :segment-selector (* 3 8)) - bytes))))) + (let* ((byte-list + (with-binary-output-to-list (bytes) + (loop for trampoline across trampolines + as exception-vector upfrom 0 + do (let* ((trampoline-address (movitz-intern (find-primitive-function trampoline))) + (symtab (movitz-env-get trampoline :symtab)) + (trampoline-offset (cdr (assoc exception-vector symtab)))) + (assert symtab () + "No symtab for exception trampoline ~S." trampoline) + (write-binary-record + (make-gate-descriptor ':interrupt + (+ (slot-offset 'movitz-basic-vector 'data) + trampoline-address + trampoline-offset) + :segment-selector (* 3 8)) + bytes)))))) (let ((l32 (merge-bytes byte-list 8 32))) (movitz-intern (make-movitz-vector (length l32) :element-type '(unsigned-byte 32) From ffjeld at common-lisp.net Tue Aug 10 13:28:05 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 10 Aug 2004 06:28:05 -0700 Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv22016 Modified Files: special-operators.lisp Log Message: Made define-primitive-function accept options for the pf somewhat like defstruct does. I.e. (define-primitive-function (foo-pf :symtab-property t) () ...) will make the symbol-value of foo-pf be a (primitive) code-vector as usual, but also the code-vector's symbol-table will be put into the symbol's :symtab property. Date: Tue Aug 10 06:28:05 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.34 movitz/special-operators.lisp:1.35 --- movitz/special-operators.lisp:1.34 Fri Aug 6 07:45:30 2004 +++ movitz/special-operators.lisp Tue Aug 10 06:28:05 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.34 2004/08/06 14:45:30 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.35 2004/08/10 13:28:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -272,12 +272,19 @@ (define-special-operator make-primitive-function (&form form &env env) (destructuring-bind (name docstring body) (cdr form) - (handler-bind (((or warning error) (lambda (c) - (declare (ignore c)) - (format *error-output* "~&;; In primitive function ~S:" name)))) - (let ((code-vector (make-compiled-primitive body env nil docstring))) - (setf (movitz-symbol-value (movitz-read name)) code-vector) - (compiler-values ()))))) + (destructuring-bind (name &key symtab-property) + (if (consp name) name (list name)) + (handler-bind (((or warning error) + (lambda (c) + (declare (ignore c)) + (format *error-output* "~&;; In primitive function ~S:" name)))) + (multiple-value-bind (code-vector symtab) + (make-compiled-primitive body env nil docstring) + (setf (movitz-symbol-value (movitz-read name)) code-vector) + (when symtab-property + (setf (movitz-env-get name :symtab) + (translate-program symtab :movitz :muerte))) + (compiler-values ())))))) (define-special-operator define-prototyped-function (&form form) (destructuring-bind (function-name proto-name &rest parameters) From ffjeld at common-lisp.net Wed Aug 11 09:34:30 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 11 Aug 2004 02:34:30 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/read.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11073 Modified Files: read.lisp Log Message: Improved the reader to do the right thing on e.g. "#20r14" and "#100(a b c)". Date: Wed Aug 11 02:34:30 2004 Author: ffjeld Index: movitz/losp/muerte/read.lisp diff -u movitz/losp/muerte/read.lisp:1.8 movitz/losp/muerte/read.lisp:1.9 --- movitz/losp/muerte/read.lisp:1.8 Tue Jul 27 07:43:30 2004 +++ movitz/losp/muerte/read.lisp Wed Aug 11 02:34:30 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Oct 17 21:50:42 2001 ;;;; -;;;; $Id: read.lisp,v 1.8 2004/07/27 14:43:30 ffjeld Exp $ +;;;; $Id: read.lisp,v 1.9 2004/08/11 09:34:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -278,52 +278,62 @@ string end)))) (#\# (assert (< (incf i) end) (string) "End of string after #: ~S." (substring string start end)) - (return-from simple-read-from-string - (ecase (char-downcase (char string i)) - (#\b (simple-read-integer string (1+ i) end 2)) - (#\o (simple-read-integer string (1+ i) end 8)) - (#\x (simple-read-integer string (1+ i) end 16)) - (#\' (multiple-value-bind (quoted-form form-end) - (simple-read-from-string string eof-error-p eof-value :start (1+ i) :end end) - (values (list 'function quoted-form) form-end string end))) - (#\( (multiple-value-bind (contents-list form-end) - (simple-read-delimited-list #\) string (1+ i) end) - (values (make-array (length contents-list) - :initial-contents contents-list) - form-end - string end))) - (#\* (let* ((token-end (find-token-end string :start (incf i) :end end)) - (bit-vector (make-array (- token-end i) :element-type 'bit))) - (do ((p i (1+ p)) - (q 0 (1+ q))) - ((>= p token-end)) - (case (schar string p) - (#\0 (setf (aref bit-vector q) 0)) - (#\1 (setf (aref bit-vector q) 1)) - (t (error "Illegal bit-vector element: ~S" (schar string p))))) - (values bit-vector - token-end - string end))) - (#\s (multiple-value-bind (struct-form form-end) - (simple-read-from-string string eof-error-p eof-value :start (1+ i) :end end) - (check-type struct-form list) - (let* ((struct-name (car struct-form)) - (struct-args (cdr struct-form))) - (check-type struct-name symbol "A structure name.") - (values (apply #'make-structure struct-name struct-args) - form-end string end)))) - (#\: (let* ((token-end (find-token-end string :start (incf i) :end end)) - (symbol-name (string-upcase string :start i :end token-end))) - (values (make-symbol symbol-name) - token-end string end))) - (#\\ (let* ((token-end (find-token-end string :start (incf i) :end end)) - (char (name-char string i token-end))) - (cond - (char (values char token-end)) - ((>= 1 (- token-end i)) - (values (char string i) (1+ i) string end)) - (t (error "Don't know this character: ~S" - (substring string i token-end))))))))) + (multiple-value-bind (parameter parameter-end) + (parse-integer string :start i :end end :radix 10 :junk-allowed t) + (setf i parameter-end) + (return-from simple-read-from-string + (ecase (char-downcase (char string i)) + (#\b (simple-read-integer string (1+ i) end 2)) + (#\o (simple-read-integer string (1+ i) end 8)) + (#\x (simple-read-integer string (1+ i) end 16)) + (#\r (check-type parameter (integer 2 36)) + (simple-read-integer string (1+ i) end parameter)) + (#\' (multiple-value-bind (quoted-form form-end) + (simple-read-from-string string eof-error-p eof-value :start (1+ i) :end end) + (values (list 'function quoted-form) form-end string end))) + (#\( (multiple-value-bind (contents-list form-end) + (simple-read-delimited-list #\) string (1+ i) end) + (values (replace (make-array (or parameter (length contents-list)) + :initial-element (car (last contents-list))) + contents-list) + form-end + string end))) + (#\* (let* ((token-end (find-token-end string :start (incf i) :end end)) + (bit-vector (make-array (or parameter (- token-end i)) + :element-type 'bit))) + (do ((p i (1+ p)) + (q 0 (1+ q)) + (bit nil)) + ((>= q (length bit-vector))) + (when (< p token-end) + (setf bit (schar string p))) + (case bit + (#\0 (setf (aref bit-vector q) 0)) + (#\1 (setf (aref bit-vector q) 1)) + (t (error "Illegal bit-vector element: ~S" bit)))) + (values bit-vector + token-end + string end))) + (#\s (multiple-value-bind (struct-form form-end) + (simple-read-from-string string eof-error-p eof-value :start (1+ i) :end end) + (check-type struct-form list) + (let* ((struct-name (car struct-form)) + (struct-args (cdr struct-form))) + (check-type struct-name symbol "A structure name.") + (values (apply #'make-structure struct-name struct-args) + form-end string end)))) + (#\: (let* ((token-end (find-token-end string :start (incf i) :end end)) + (symbol-name (string-upcase string :start i :end token-end))) + (values (make-symbol symbol-name) + token-end string end))) + (#\\ (let* ((token-end (find-token-end string :start (incf i) :end end)) + (char (name-char string i token-end))) + (cond + (char (values char token-end)) + ((>= 1 (- token-end i)) + (values (char string i) (1+ i) string end)) + (t (error "Don't know this character: ~S" + (substring string i token-end)))))))))) (t (return-from simple-read-from-string (simple-read-token string :start i :end end)))))) From ffjeld at common-lisp.net Thu Aug 12 15:42:00 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 12 Aug 2004 08:42:00 -0700 Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv17217 Modified Files: procfs-image.lisp Log Message: Fixed typo: the type is movitz-null, not movitz-nil. Date: Thu Aug 12 08:42:00 2004 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.14 movitz/procfs-image.lisp:1.15 --- movitz/procfs-image.lisp:1.14 Fri Aug 6 07:43:51 2004 +++ movitz/procfs-image.lisp Thu Aug 12 08:42:00 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.14 2004/08/06 14:43:51 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.15 2004/08/12 15:42:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -109,7 +109,7 @@ (cons (mapcar #'movitz-print expr)) ((not movitz-object) expr) - ((or movitz-nil movitz-run-time-context) nil) + ((or movitz-null movitz-run-time-context) nil) (movitz-std-instance expr) (movitz-symbol (intern (movitz-print (movitz-symbol-name expr)))) From ffjeld at common-lisp.net Thu Aug 12 15:42:59 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 12 Aug 2004 08:42:59 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cpu-id.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv32642 Modified Files: cpu-id.lisp Log Message: Removed dead debugging statement. Date: Thu Aug 12 08:42:59 2004 Author: ffjeld Index: movitz/losp/muerte/cpu-id.lisp diff -u movitz/losp/muerte/cpu-id.lisp:1.7 movitz/losp/muerte/cpu-id.lisp:1.8 --- movitz/losp/muerte/cpu-id.lisp:1.7 Tue Jul 20 16:51:05 2004 +++ movitz/losp/muerte/cpu-id.lisp Thu Aug 12 08:42:59 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Apr 15 22:47:13 2002 ;;;; -;;;; $Id: cpu-id.lisp,v 1.7 2004/07/20 23:51:05 ffjeld Exp $ +;;;; $Id: cpu-id.lisp,v 1.8 2004/08/12 15:42:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -216,9 +216,9 @@ (define-compiler-macro eflags () `(with-inline-assembly (:returns :register) + ;; XXXXX Breaks stack and register disciplines! (:pushfl) (:popl (:result-register)) - (:movl (:result-register) (#x1000)) (:shll 2 (:result-register)))) (defun eflags () From ffjeld at common-lisp.net Thu Aug 12 16:54:52 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 12 Aug 2004 09:54:52 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/textmode.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv12480 Modified Files: textmode.lisp Log Message: Make the variables that define the textmode memory location into proper dynamic variables. Date: Thu Aug 12 09:54:52 2004 Author: ffjeld Index: movitz/losp/x86-pc/textmode.lisp diff -u movitz/losp/x86-pc/textmode.lisp:1.10 movitz/losp/x86-pc/textmode.lisp:1.11 --- movitz/losp/x86-pc/textmode.lisp:1.10 Mon Aug 9 07:39:46 2004 +++ movitz/losp/x86-pc/textmode.lisp Thu Aug 12 09:54:51 2004 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001,2000, 2002-2004, +;;;; Copyright (C) 2000-2004, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: textmode.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 9 15:38:56 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: textmode.lisp,v 1.10 2004/08/09 14:39:46 ffjeld Exp $ +;;;; $Id: textmode.lisp,v 1.11 2004/08/12 16:54:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -23,22 +23,22 @@ (in-package muerte.x86-pc) -(define-global-variable *screen* +(defvar *screen* (vga-memory-map)) -(define-global-variable *screen-width* +(defvar *screen-width* (vga-horizontal-display-end)) -(define-global-variable *screen-stride* +(defvar *screen-stride* (vga-horizontal-display-end)) -(define-global-variable *cursor-x* +(defvar *cursor-x* (rem (vga-cursor-location) *screen-stride*)) -(define-global-variable *cursor-y* +(defvar *cursor-y* (truncate (vga-cursor-location) *screen-stride*)) -(define-global-variable *screen-height* +(defvar *screen-height* (truncate (vga-vertical-display-end) (vga-character-height))) From ffjeld at common-lisp.net Thu Aug 12 16:57:16 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 12 Aug 2004 09:57:16 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv28233 Modified Files: interrupt.lisp Log Message: Rename interrupt-frame- to dit-frame ("default-interrupt-trampoline-frame-"). Also, reworked the default-interrupt-trampoline a bit, re-arranged the frame layout etc. Date: Thu Aug 12 09:57:15 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.19 movitz/losp/muerte/interrupt.lisp:1.20 --- movitz/losp/muerte/interrupt.lisp:1.19 Tue Jul 27 06:50:08 2004 +++ movitz/losp/muerte/interrupt.lisp Thu Aug 12 09:57:15 2004 @@ -10,59 +10,77 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.19 2004/07/27 13:50:08 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.20 2004/08/12 16:57:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ -(in-package #:muerte) +(in-package muerte) (provide :muerte/interrupt) -(defvar *last-interrupt-frame* nil) +(defvar *last-dit-frame* nil) -(defmacro stack-word (offset) - `(with-inline-assembly (:returns :eax) - (:movl (:esp ,(* 4 offset)) :eax))) +(defun dit-frame-esp (dit-frame) + (+ dit-frame 6)) -(define-compiler-macro interrupt-frame-index (&whole form name &environment env) +(defconstant +dit-frame-map+ + '(nil :eflags :eip :error-code :exception-vector :ebp :funobj + :edi + :atomically-status + :atomically-esp + :scratch0 + :ecx :eax :edx :ebx :esi)) + +(define-compiler-macro dit-frame-index (&whole form name &environment env) (let ((name (and (movitz:movitz-constantp name env) (movitz:movitz-eval name env)))) (if (not name) form - (- 5 (position name - '(nil :eflags :eip :error-code :exception :ebp nil - :ecx :eax :edx :ebx :esi :edi :atomically-status)))))) - -(defun interrupt-frame-index (name) - (- 5 (position name - '(nil :eflags :eip :error-code :exception :ebp nil - :ecx :eax :edx :ebx :esi :edi :atomically-status)))) + (- 5 (position name +dit-frame-map+))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun dit-frame-index (name) + (- 5 (position name +dit-frame-map+))) + (defun dit-frame-offset (name) + (* 4 (dit-frame-index name)))) -(define-compiler-macro interrupt-frame-ref (&whole form reg type +(define-compiler-macro dit-frame-ref (&whole form reg type &optional (offset 0) - (frame '*last-interrupt-frame*) + (frame '*last-dit-frame*) &environment env) - `(memref ,frame (+ (* 4 (interrupt-frame-index ,reg)) ,offset) 0 ,type)) + `(memref ,frame (+ (dit-frame-offset ,reg) ,offset) 0 ,type)) -(defun interrupt-frame-ref (reg type &optional (offset 0) (frame *last-interrupt-frame*)) - (interrupt-frame-ref reg type offset frame)) +(defun dit-frame-ref (reg type &optional (offset 0) (frame *last-dit-frame*)) + (dit-frame-ref reg type offset frame)) -(defun (setf interrupt-frame-ref) (x reg type &optional (frame *last-interrupt-frame*)) - (setf (memref frame (* 4 (interrupt-frame-index reg)) 0 type) x)) +(defun (setf dit-frame-ref) (x reg type &optional (frame *last-dit-frame*)) + (setf (memref frame (dit-frame-offset reg) 0 type) x)) -(define-primitive-function default-interrupt-trampoline () - "Default first-stage interrupt handler." +(defun dit-frame-casf (dit-frame) + "Compute the `currently active stack-frame' when the interrupt occurred." + (let ((ebp (dit-frame-ref :ebp :lisp 0 dit-frame)) + (esp (dit-frame-esp dit-frame))) + (if (< esp ebp) + ebp + (let ((next-ebp (memref ebp 0 0 :lisp))) + (check-type next-ebp fixnum) + (assert (< esp next-ebp)) + next-ebp)))) + +(define-primitive-function (default-interrupt-trampoline :symtab-property t) () + "Default first-stage/trampoline interrupt handler. Assumes the IF flag in EFLAGS +is off, e.g. because this interrupt/exception is routed through an interrupt gate." (macrolet ((do-it () `(with-inline-assembly (:returns :multiple-values) - ,@(loop for i from 0 to movitz::+idt-size+ + ,@(loop for i from 0 to 255 + append (list i) append (if (member i '(8 10 11 12 13 14 17)) - `(((5) :pushl ,i) - ((5) :jmp 'ok)) - `(((2) :pushl 0) ; replace Error Code - ((2) :pushl ,i) - ((1) :nop) - ((5) :jmp 'ok)))) + `((:pushl ,i) + (:jmp 'ok)) + `((:pushl 0) ; replace Error Code + (:pushl ,i) + (:jmp 'ok)))) ok ;; Stack: ;; 20: Interruptee EFLAGS (later EIP) @@ -73,16 +91,16 @@ ;; 0: EBP (:pushl :ebp) (:movl :esp :ebp) - (:pushl 0) ; 0 means default-interrupt-trampoline frame - (:pushl :ecx) ; -8 - (:pushl :eax) ; -12 - (:pushl :edx) ; -16 - (:pushl :ebx) ; -20 - (:pushl :esi) ; -24 + (:pushl 0) ; 0 'funobj' means default-interrupt-trampoline frame (:pushl :edi) ; -28 (:movl ':nil-value :edi) ; We want NIL! - (:locally (:pushl (:edi (:edi-offset atomically-status)))) ; -32 - (:locally (:pushl (:edi (:edi-offset atomically-esp)))) ; -36 + (:locally (:pushl (:edi (:edi-offset atomically-status)))) + (:locally (:pushl (:edi (:edi-offset atomically-esp)))) + (:locally (:pushl (:edi (:edi-offset scratch0)))) + ,@(loop for reg in (sort (copy-list '(:eax :ebx :ecx :edx :esi)) + #'> + :key #'dit-frame-index) + collect `(:pushl ,reg)) (:locally (:movl 0 (:edi (:edi-offset atomically-status)))) @@ -110,7 +128,7 @@ ;; Save/push thread-local values (:locally (:movl (:edi (:edi-offset num-values)) :ecx)) (:jecxz 'push-values-done) - (:leal (:edi #.(movitz::global-constant-offset 'values)) :eax) + (:leal (:edi (:offset movitz-run-time-context values)) :eax) push-values-loop (:locally (:pushl (:eax))) (:addl 4 :eax) @@ -120,12 +138,11 @@ (:locally (:pushl (:edi (:edi-offset num-values)))) ;; call handler - (:movl (:ebp 4) :ecx) ; interrupt number into ECX - (:locally (:movl (:edi (:edi-offset interrupt-handlers)) :eax)) - (:movl (:eax 2 (:ecx 4)) :esi) ; funobj at (aref EBX interrupt-handlers) into :esi - (:movl :ebp :ebx) ; pass interrupt-frame as arg1 - (:movl (:ebp 4) :ecx) ; pass interrupt number as arg 0. - (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax) + (:movl (:ebp ,(dit-frame-offset :exception-vector)) :ecx) + (:locally (:movl (:edi (:edi-offset exception-handlers)) :eax)) + (:movl (:eax 2 (:ecx 4)) :esi) ; funobj at (aref ECX exception-handlers) into :esi + (:movl :ebp :ebx) ; pass dit-frame as arg1 + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax) ; pass interrupt number as arg 0. (:call (:esi ,(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%2op))) skip-interrupt-handler @@ -140,40 +157,43 @@ (:jnz 'pop-values-loop) pop-values-done - (:movl (:ebp -32) :ecx) ; Check interruptee's atomically status + (:movl (:ebp ,(dit-frame-offset :atomically-status)) :ecx) (:testb :cl :cl) (:jnz 'restart-atomical-block) ;; Interrupted code was non-atomical, the normal case. normal-return ; With atomically-status-to-restore in ECX (:locally (:movl :ecx (:edi (:edi-offset atomically-status)))) - (:movl (:ebp -36) :ecx) ; Load interruptee's atomically-esp.. - (:locally (:movl :ecx (:edi (:edi-offset atomically-esp)))) ; ..and restore it. - (:movl (:ebp -28) :edi) - (:movl (:ebp -24) :esi) - (:movl (:ebp -20) :ebx) - (:movl (:ebp -16) :edx) - (:movl (:ebp -12) :eax) - (:movl (:ebp -8) :ecx) - ;; Make stack safe before we exit interrupt-frame.. + (:movl (:ebp ,(dit-frame-offset :atomically-esp)) :ecx) + (:locally (:movl :ecx (:edi (:edi-offset atomically-esp)))) + (:movl (:ebp ,(dit-frame-offset :scratch0)) :ecx) + (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) + (:movl (:ebp ,(dit-frame-offset :edi)) :edi) + (:movl (:ebp ,(dit-frame-offset :esi)) :esi) + (:movl (:ebp ,(dit-frame-offset :ebx)) :ebx) + (:movl (:ebp ,(dit-frame-offset :edx)) :edx) + (:movl (:ebp ,(dit-frame-offset :eax)) :eax) + (:movl (:ebp ,(dit-frame-offset :ecx)) :ecx) + ;; Make stack safe before we exit dit-frame.. (:movl :edi (:ebp 4)) (:movl :edi (:ebp 8)) (:movl :edi (:ebp 12)) + (:cli) ; Clear IF in EFLAGS before leaving dit-frame. (:leave) (:addl 12 :esp) - (:popfl) ; pop EFLAGS + (:popfl) ; pop EFLAGS (also resets IF) (:ret) ; pop EIP restart-atomical-block (:cmpb ,(bt:enum-value 'movitz::atomically-status :restart-primitive-function) :cl) (:jne 'not-simple-atomical-pf-restart) - (:testl #xff00 :ecx) ; map of registers to restore + (:testl #xfe00 :ecx) ; map of registers to restore (:jnz 'not-simple-atomical-pf-restart) (:sarl 16 :ecx) ; move atomically-status data into ECX (:movl (:edi (:ecx 4) ,(- (movitz:tag :null))) :ecx) ; This is the EIP to restart (:movl :ecx (:ebp 20)) - (:movl (:ebp -32) :ecx) + (:movl (:ebp ,(dit-frame-offset :atomically-status)) :ecx) (:testl ,(bt:enum-value 'movitz::atomically-status :reset-status-p) :ecx) ; Should we reset status to zero? (:jnz 'normal-return) @@ -187,9 +207,9 @@ (:jnz 'atomically-esp-ok) ;; Generate the correct ESP for interruptee's atomically-esp (:leal (:ebp 24) :ecx) - (:movl :ecx (:ebp -36)) + (:movl :ecx (:ebp ,(dit-frame-offset :atomically-esp))) atomically-esp-ok - (:movl (:ebp -32) :ecx) + (:movl (:ebp ,(dit-frame-offset :atomically-status)) :ecx) (:testl ,(bt:enum-value 'movitz::atomically-status :reset-status-p) :ecx) ; Should we reset status to zero? (:jnz 'atomically-jumper-return) @@ -197,22 +217,22 @@ atomically-jumper-return (:locally (:movl :ecx (:edi (:edi-offset atomically-status)))) - (:movl (:ebp -36) :ecx) ; Load interruptee's atomically-esp.. + (:movl (:ebp ,(dit-frame-offset :atomically-esp)) :ecx) ; Load interruptee's atomically-esp.. (:locally (:movl :ecx (:edi (:edi-offset atomically-esp)))) ; ..and restore it. (:testl #x40 (:ebp 16)) ; Test EFLAGS bit DF (:jnz 'atomically-jumper-return-dirty-registers) - (:movl (:ebp -28) :edi) - (:movl (:ebp -24) :esi) - (:movl (:ebp -16) :edx) - (:movl (:ebp -12) :eax) - (:movl (:ebp -8) :ecx) + (:movl (:ebp ,(dit-frame-offset :edi)) :edi) + (:movl (:ebp ,(dit-frame-offset :esi)) :esi) + (:movl (:ebp ,(dit-frame-offset :edx)) :edx) + (:movl (:ebp ,(dit-frame-offset :eax)) :eax) + (:movl (:ebp ,(dit-frame-offset :ecx)) :ecx) - (:movl (:ebp -32) :ebx) ; atomically-status.. + (:movl (:ebp ,(dit-frame-offset :atomically-status)) :ebx) ; atomically-status.. (:shrl ,(- 16 movitz:+movitz-fixnum-shift+) :ebx) - ;; Make stack safe before we exit interrupt-frame.. + ;; Make stack safe before we exit dit-frame.. (:movl :edi (:ebp 4)) (:movl :edi (:ebp 8)) (:movl :edi (:ebp 12)) @@ -220,6 +240,7 @@ (:movl :edi (:ebp 20)) (:movl (:ebp 0) :ebp) ; pop stack-frame (: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))) atomically-jumper-return-dirty-registers @@ -228,20 +249,21 @@ ;; DF will be cleared. (:movl :edi :edx) (:movl :edi :eax) - (:movl :edi :ecx) + (:movl :edi :ecx) - (:movl (:ebp -32) :ebx) ; atomically-status.. + (:movl (:ebp ,(dit-frame-offset :atomically-status)) :ebx) (:shrl ,(- 16 movitz:+movitz-fixnum-shift+) :ebx) - ;; Make stack safe before we exit interrupt-frame.. + ;; Make stack safe before we exit dit-frame.. (:movl :edi (:ebp 4)) (:movl :edi (:ebp 8)) (:movl :edi (:ebp 12)) (:movl :edi (:ebp 16)) (:movl :edi (:ebp 20)) - (:movl (:ebp 0) :ebp) ; pop interrupt-frame + (:movl (:ebp 0) :ebp) ; pop dit-frame (: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))) not-simple-restart-jumper @@ -252,27 +274,28 @@ ))) (do-it))) -(defun interrupt-default-handler (number interrupt-frame) +(defun interrupt-default-handler (vector dit-frame) (declare (without-check-stack-limit)) + (cli) (macrolet ((dereference (fixnum-address &optional (type :lisp)) "Dereference the fixnum-address." `(memref ,fixnum-address 0 0 ,type))) - (let (($eip (+ interrupt-frame (interrupt-frame-index :eip))) - ($eax (+ interrupt-frame (interrupt-frame-index :eax))) - ($ebx (+ interrupt-frame (interrupt-frame-index :ebx))) - ($ecx (+ interrupt-frame (interrupt-frame-index :ecx))) - ($edx (+ interrupt-frame (interrupt-frame-index :edx))) - ($esi (+ interrupt-frame (interrupt-frame-index :esi))) - (*last-interrupt-frame* interrupt-frame)) + (let (($eip (+ dit-frame (dit-frame-index :eip))) + ($eax (+ dit-frame (dit-frame-index :eax))) + ($ebx (+ dit-frame (dit-frame-index :ebx))) + ($ecx (+ dit-frame (dit-frame-index :ecx))) + ($edx (+ dit-frame (dit-frame-index :edx))) + ($esi (+ dit-frame (dit-frame-index :esi))) + (*last-dit-frame* dit-frame)) (block nil - (case number + (case vector (0 (error 'division-by-zero)) (3 (break "Break instruction at ~@Z." $eip)) (4 (error "Primitive overflow assertion failed.")) (6 (error "Illegal instruction at ~@Z." $eip)) (13 (error "General protection error. EIP=~@Z, error-code: #x~X, EAX: ~@Z, EBX: ~@Z, ECX: ~@Z" $eip - (interrupt-frame-ref :error-code :unsigned-byte32 0 interrupt-frame) + (dit-frame-ref :error-code :unsigned-byte32 0 dit-frame) $eax $ebx $ecx)) ((60) ;; EAX failed type in EDX. May be restarted by returning with a new value in EAX. @@ -286,7 +309,7 @@ (64 (error 'type-error :datum (dereference $eax) :expected-type 'integer)) (65 (error 'index-out-of-range :index (dereference $ebx) (dereference $ecx))) (66 (error "Unspecified type error at ~@Z in ~S with EAX=~@Z, ECX=~@Z." - $eip (dereference (+ interrupt-frame (interrupt-frame-index :esi))) + $eip (dereference (+ dit-frame (dit-frame-index :esi))) $eax $ecx)) (67 (backtrace :fresh-lines nil :length 6) (dotimes (i 100000) @@ -295,6 +318,7 @@ $eip $eax $ebx $ecx $edx) (dotimes (i 100000) (with-inline-assembly (:returns :nothing) (:nop)))) + (70 (error "Unaligned memref access.")) ((5 55) (let* ((old-bottom (prog1 (stack-bottom) (setf (stack-bottom) 0))) @@ -317,8 +341,8 @@ (- old-bottom new-bottom) new-bottom) (break "Stack overload exception ~D at EIP=~@Z, ESI=~@Z, ESP=~@Z, bottom=#x~X." - number $eip $esi - (+ interrupt-frame (interrupt-frame-index :ebp)) + vector $eip $esi + (+ dit-frame (dit-frame-index :ebp)) old-bottom)) (format *debug-io* "~&Stack-warning: Resetting stack-bottom to #x~X.~%" old-bottom) @@ -336,13 +360,13 @@ (when (symbolp name) (error 'unbound-variable :name name)))) ((100);; 101 102 103 104 105) - (let ((funobj (dereference (+ interrupt-frame (interrupt-frame-index :esi)))) - (code (interrupt-frame-ref :ecx :unsigned-byte8 0 interrupt-frame))) + (let ((funobj (dereference (+ dit-frame (dit-frame-index :esi)))) + (code (dit-frame-ref :ecx :unsigned-byte8 0 dit-frame))) (error 'wrong-argument-count :function funobj :argument-count (if (logbitp 7 code) - (ash (interrupt-frame-ref :ecx :unsigned-byte32 - 0 interrupt-frame) + (ash (dit-frame-ref :ecx :unsigned-byte32 + 0 dit-frame) -24) code)))) (108 @@ -353,20 +377,20 @@ (112 (let ((*error-no-condition-for-debugger* t)) ; no space.. (error "Out of memory. Please take out the garbage."))) - (t (funcall (if (< 16 number 50) #'warn #'error) + (t (funcall (if (< 16 vector 50) #'warn #'error) "Exception occurred: ~D, EIP: ~@Z, EAX: ~@Z, ECX: ~@Z, ESI: ~@Z" - number $eip $eax $ecx $esi))) + vector $eip $eax $ecx $esi))) nil)))) -(defun exception-handler (n) - (let ((vector (load-global-constant interrupt-handlers))) - (svref vector n))) +(defun exception-handler (vector) + (let ((handlers (load-global-constant exception-handlers))) + (svref handlers vector))) -(defun (setf exception-handler) (handler n) +(defun (setf exception-handler) (handler vector) (check-type handler function) - (let ((vector (load-global-constant interrupt-handlers))) - (setf (svref vector n) handler))) + (let ((handlers (load-global-constant exception-handlers))) + (setf (svref handlers vector) handler))) (defun cli () (with-inline-assembly (:returns :nothing) @@ -376,17 +400,17 @@ (with-inline-assembly (:returns :nothing) (:sti))) -(defun raise-exception (exception &optional (eax 0) (ebx 0)) +(defun raise-exception (vector &optional (eax 0) (ebx 0)) "Generate a CPU exception, with those values in EAX and EBX." ;; The problem now is that the x86 INT instruction only takes an ;; immediate argument. - (check-type exception (unsigned-byte 8)) + (check-type vector (unsigned-byte 8)) (macrolet ((do-it () `(with-inline-assembly (:returns :eax) (:load-lexical (:lexical-binding eax) :eax) (:load-lexical (:lexical-binding ebx) :ebx) - (:load-lexical (:lexical-binding exception) :ecx) + (:load-lexical (:lexical-binding vector) :ecx) (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) (:jnz 'not-0) (:int 0) From ffjeld at common-lisp.net Thu Aug 12 16:58:20 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 12 Aug 2004 09:58:20 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/lists.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11202 Modified Files: lists.lisp Log Message: Removed some bogus declarations. Date: Thu Aug 12 09:58:19 2004 Author: ffjeld Index: movitz/losp/muerte/lists.lisp diff -u movitz/losp/muerte/lists.lisp:1.8 movitz/losp/muerte/lists.lisp:1.9 --- movitz/losp/muerte/lists.lisp:1.8 Wed Jul 21 07:15:37 2004 +++ movitz/losp/muerte/lists.lisp Thu Aug 12 09:58:19 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.8 2004/07/21 14:15:37 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.9 2004/08/12 16:58:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -20,11 +20,9 @@ (in-package muerte) (defun first (x) - (declare (type list x)) (car x)) (defun rest (x) - (declare (type list x)) (cdr x)) ;; Compiler-macros for first and rest in basic-macros.lisp. From ffjeld at common-lisp.net Thu Aug 12 17:00:29 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 12 Aug 2004 10:00:29 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10882 Modified Files: memref.lisp Log Message: Added memref type :location, wich is a word whose lower 2 bits are cleared. Date: Thu Aug 12 10:00:29 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.25 movitz/losp/muerte/memref.lisp:1.26 --- movitz/losp/muerte/memref.lisp:1.25 Tue Aug 10 05:58:28 2004 +++ movitz/losp/muerte/memref.lisp Thu Aug 12 10:00:29 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.25 2004/08/10 12:58:28 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.26 2004/08/12 17:00:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -202,6 +202,28 @@ (:load-lexical (:lexical-binding ,object-var) :ebx) (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale offset+index (:movb (:ebx :ecx ,(offset-by 1)) :ah))))))) + (:location + (assert (= 4 movitz::+movitz-fixnum-factor+)) + (cond + ((and (eq 0 offset) (eq 0 index)) + `(with-inline-assembly (:returns :ecx) + (:compile-form (:result-mode :eax) ,object) + (:movl (:eax ,(offset-by 4)) :ecx) + (:andl -4 :ecx))) + ((eq 0 offset) + `(with-inline-assembly (:returns :ecx) + (:compile-two-forms (:eax :ecx) ,object ,index) + (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (:andl -4 :ecx))) + (t (let ((object-var (gensym "memref-object-"))) + `(let ((,object-var ,object)) + (with-inline-assembly (:returns :ecx) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :eax) + (:addl :ebx :ecx) + (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (:andl -4 :ecx))))))) (:unsigned-byte32 (assert (= 4 movitz::+movitz-fixnum-factor+)) (cond From ffjeld at common-lisp.net Thu Aug 12 17:01:27 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 12 Aug 2004 10:01:27 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3264 Modified Files: sequences.lisp Log Message: Added some type declarations here and there. Date: Thu Aug 12 10:01:27 2004 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.15 movitz/losp/muerte/sequences.lisp:1.16 --- movitz/losp/muerte/sequences.lisp:1.15 Sun Jul 11 15:47:10 2004 +++ movitz/losp/muerte/sequences.lisp Thu Aug 12 10:01:26 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.15 2004/07/11 22:47:10 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.16 2004/08/12 17:01:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -19,6 +19,9 @@ (in-package muerte) +(deftype index () + '(integer 0 #x1ffffffe)) + (defun sequencep (x) (or (typep x 'vector) (typep x 'cons))) @@ -691,6 +694,7 @@ (with-subvector-accessor (sequence-ref sequence start end) (do ((i start (1+ i))) ((>= i end)) + (declare (index i)) (setf (sequence-ref i) item)))))) sequence) @@ -712,6 +716,7 @@ (i (+ start1 length -1) (1- i)) (j (+ start2 length -1) (1- j))) ((< i start1) sequence-1) + (declare (index i j length)) (setf (sequence-1-ref i) (sequence-1-ref j))))) (list From ffjeld at common-lisp.net Thu Aug 12 17:11:56 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 12 Aug 2004 10:11:56 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12386 Modified Files: scavenge.lisp Log Message: Re-wrote map-heap-words according to the now written-down stack discipline. Date: Thu Aug 12 10:11:56 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.25 movitz/losp/muerte/scavenge.lisp:1.26 --- movitz/losp/muerte/scavenge.lisp:1.25 Fri Jul 23 08:27:43 2004 +++ movitz/losp/muerte/scavenge.lisp Thu Aug 12 10:11:55 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.25 2004/07/23 15:27:43 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.26 2004/08/12 17:11:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -127,7 +127,7 @@ #.(bt:enum-value 'movitz:movitz-vector-element-type :any-t)))) (error "Scanned unknown basic-vector #x~Z at address #x~X." x scan)) ((scavenge-typep x :old-vector) - (error "Scanned old-vector #x~Z at address #x~X." x scan)) + (error "Scanned old-vector ~Z at address #x~X." x scan)) ((eq x (%lispval-object 3)) (incf scan) (let ((delta (memref scan 0 0 :lisp))) @@ -153,50 +153,50 @@ (function (assert (= 0 (funobj-frame-num-unboxed funobj))) (map-heap-words function (+ nether-frame 2) frame)) - ((eql 0) ; An interrupt-frame? - ;; 1. Scavenge the interrupt-frame - (map-heap-words function - (+ nether-frame 2) - (+ frame (interrupt-frame-index :ecx))) - (let* ((interrupt-frame frame) - (interrupted-eip-loc - (interrupt-frame-ref :eip :signed-byte30+2 0 interrupt-frame))) - ;; 2. Pop to interrupted frame + ((eql 0) ; An dit interrupt-frame? + (let* ((dit-frame frame) + (casf-frame (dit-frame-casf dit-frame))) + ;; 1. Scavenge the dit-frame + (cond + ((logbitp 10 (dit-frame-ref :eflags :unsigned-byte32 0 dit-frame)) + ;; DF flag was 1, so EAX and EDX are not GC roots. + (warn "Interrupt in uncommon mode at ~S" + (dit-frame-ref :eip :unsigned-byte32 0 dit-frame)) + (map-heap-words function ; Assume nothing in the dit-frame above the location .. + (+ nether-frame 2) ; ..of EBX holds pointers. + (+ frame (dit-frame-index :ebx)))) + (t (warn "Interrupt in COMMON mode!") + (map-heap-words function ; Assume nothing in the dit-frame above the location .. + (+ nether-frame 2) ; ..of ECX holds pointers. + (+ frame (dit-frame-index :ecx))))) + ;; 2. Pop to (dit-)frame's CASF (setf nether-frame frame - frame (stack-frame-uplink frame)) - (let ((interrupted-funobj (funcall function (stack-frame-funobj frame t) nil)) - (interrupted-esp (+ interrupt-frame 6))) - (assert (typep interrupted-funobj 'function) () - "Interrupted frame was not a normal function: ~S" - interrupted-funobj) - ;; 3. Scavenge the interrupted frame, skipping EFLAGS etc. - (if (location-in-object-p (funobj-code-vector interrupted-funobj) - interrupted-eip-loc) - ;; The simple case: The interruptee matches interrupted EIP - (map-heap-words function interrupted-esp frame) - (let ((primitive-function - (stack-frame-primitive-funcall interrupted-funobj - interrupted-esp - interrupted-eip-loc))) - (if (not primitive-function) - (error "Don't know how to scavenge across PF interrupt frame at ~S." - interrupt-frame) - (let ((forwarded-pf (funcall function primitive-function nil))) - ;; Next simplest case: The interruptee was in a primitive-function, - ;; with the return-address at top of stack. - (unless (eq primitive-function forwarded-pf) - ;; The PF's vector has migrated. - (let* ((interrupted-eip - (interrupt-frame-ref :eip :unsigned-byte32 0 :unsigned-byte32)) - (offset (- interrupted-eip (%object-lispval primitive-function)))) - (break "Active PF moved. PF: ~Z, fwPF: ~Z, offset: ~D, PFlen ~D." - primitive-function - forwarded-pf - offset - (+ 8 (length forwarded-pf))) - (setf (memref interrupted-esp 0 0 :unsigned-byte32) - (+ offset (%object-lispval forwarded-pf))))) - (map-heap-words function (1+ interrupted-esp) frame)))))))) + frame (dit-frame-casf frame)) + (let ((casf-funobj (funcall function (stack-frame-funobj frame t) nil)) + (interrupted-esp (dit-frame-esp dit-frame))) + (assert (typep casf-funobj 'function) () + "Interrupted CASF frame was not a normal function: ~S" + casf-funobj) + (let ((casf-code-vector (funobj-code-vector casf-funobj))) + ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii. + (cond + ((location-in-object-p casf-code-vector + (dit-frame-ref :eip :location 0 dit-frame)) + ;; Situation i. Nothing special on stack, scavenge frame normally. + (map-heap-words function interrupted-esp frame)) + ((eq casf-frame (memref interrupted-esp 0 0 :location)) + ;; Situation ii. esp(0)=CASF, esp(1)=code-vector + (assert (location-in-object-p casf-code-vector + (memref interrupted-esp 0 1 :location)) + () "Stack discipline situation ii. invariant broken. CASF=#x~X" + casf-frame) + (map-heap-words function (+ interrupted-esp 2) frame)) + (t ;; Situation iii. esp(0)=code-vector. + (assert (location-in-object-p casf-code-vector + (memref interrupted-esp 0 0 :location)) + () "Stack discipline situation iii. invariant broken. CASF=#x~X" + casf-frame) + (map-heap-words function (+ interrupted-esp 1) frame))))))) (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj))))) (values)) From ffjeld at common-lisp.net Thu Aug 12 17:16:46 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 12 Aug 2004 10:16:46 -0700 Subject: [movitz-cvs] CVS update: movitz/environment.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv8694 Modified Files: environment.lisp Log Message: Accept (declare ( *)) as type-declarations. Date: Thu Aug 12 10:16:46 2004 Author: ffjeld Index: movitz/environment.lisp diff -u movitz/environment.lisp:1.6 movitz/environment.lisp:1.7 --- movitz/environment.lisp:1.6 Mon Jun 7 15:09:56 2004 +++ movitz/environment.lisp Thu Aug 12 10:16:46 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 3 11:40:15 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: environment.lisp,v 1.6 2004/06/07 22:09:56 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.7 2004/08/12 17:16:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -360,10 +360,10 @@ ((muerte::loop-tag) (dolist (var data) (setf (movitz-env-get var declaration-identifier nil environment) t))) - (t #+ignore (let ((typespec declaration-identifier) - (vars data)) - (dolist (var vars) - (setf (movitz-env-get var :variable-type nil environment) typespec)))))) + (t (let ((typespec declaration-identifier) + (vars data)) + (dolist (var vars) + (setf (movitz-env-get var :variable-type nil environment) typespec)))))) environment) (defun make-local-movitz-environment (uplink funobj From ffjeld at common-lisp.net Thu Aug 12 17:25:07 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 12 Aug 2004 10:25:07 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10944 Modified Files: compiler.lisp Log Message: Changed (and hopefully improved) the type-inference logic quite a bit. Date: Thu Aug 12 10:25:07 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.92 movitz/compiler.lisp:1.93 --- movitz/compiler.lisp:1.92 Tue Aug 10 05:56:12 2004 +++ movitz/compiler.lisp Thu Aug 12 10:25:06 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.92 2004/08/10 12:56:12 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.93 2004/08/12 17:25:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -74,6 +74,8 @@ (defvar *compiler-produce-defensive-code* t "Try make code be extra cautious.") +(defvar *compiler-trust-user-type-declarations-p* t) + (defvar *compiling-function-name*) (defvar muerte.cl:*compile-file-pathname* nil) @@ -360,25 +362,36 @@ (thunks) (binding-types) (encoded-type - (multiple-value-list (type-specifier-encode nil)))) + (multiple-value-list (type-specifier-encode nil))) + (declared-encoded-type + (multiple-value-list (type-specifier-encode t)))) + +(defun make-type-analysis-with-declaration (binding) + (let ((declared-type + (if (not (and *compiler-trust-user-type-declarations-p* + (movitz-env-get (binding-name binding) :variable-type + nil (binding-env binding) nil))) + (multiple-value-list (type-specifier-encode t)) + (multiple-value-list + (type-specifier-encode (movitz-env-get (binding-name binding) :variable-type + t (binding-env binding) nil)))))) + ;; (warn "~S decl: ~A" binding (apply #'encoded-type-decode declared-type)) + (make-type-analysis :declared-encoded-type declared-type))) (defun analyze-bindings (toplevel-funobj) "Figure out usage of bindings in a toplevel funobj. Side-effects each binding's binding-store-type." (when *compiler-do-type-inference* - (let ((more-binding-references-p nil) - (binding-usage (make-hash-table :test 'eq))) + (let ((binding-usage (make-hash-table :test 'eq))) (labels ((binding-resolved-p (binding) (let ((analysis (gethash binding binding-usage))) (and analysis - (null (type-analysis-binding-types analysis)) (null (type-analysis-thunks analysis))))) (binding-resolve (binding) (if (not (bindingp binding)) binding (let ((analysis (gethash binding binding-usage))) (assert (and (and analysis - (null (type-analysis-binding-types analysis)) (null (type-analysis-thunks analysis)))) (binding) "Can't resolve unresolved binding ~S." binding) @@ -395,49 +408,63 @@ (assert (or (typep type 'binding) (eql 1 (type-specifier-num-values type))) () "store-lexical with multiple-valued type: ~S for ~S" type binding) + ;; (warn "store ~S type ~S, thunk ~S" binding type thunk) (let ((analysis (or (gethash binding binding-usage) (setf (gethash binding binding-usage) - (make-type-analysis))))) + (make-type-analysis-with-declaration binding))))) (cond (thunk (assert (some #'bindingp thunk-args)) +;;; (assert (notany (lambda (arg) +;;; (and (bindingp arg) +;;; (binding-eql arg binding))) +;;; thunk-args) +;;; () "A thunk on itself for ~S?" binding) (push (cons thunk thunk-args) (type-analysis-thunks analysis))) - ((typep binding 'function-argument) - (setf (type-analysis-encoded-type analysis) - (multiple-value-list - (type-specifier-encode (etypecase binding - (rest-function-argument 'list) - (supplied-p-function-argument 'boolean) - (function-argument t)))))) - ((and (consp type) (eq 'binding-type (car type))) - (let ((target-binding (binding-target (cadr type)))) - (cond - ((eq binding target-binding)) - ((typep binding 'constant-object-binding) - (setf (type-analysis-encoded-type analysis) - (multiple-value-list - (multiple-value-call - #'encoded-types-or - (values-list (type-analysis-encoded-type analysis)) - (member-type-encode (constant-object target-binding)))))) - (t (pushnew target-binding (type-analysis-binding-types analysis)) - (setf more-binding-references-p t))))) +;;; ((typep binding 'function-argument) +;;; (setf (type-analysis-encoded-type analysis) +;;; (multiple-value-list +;;; (type-specifier-encode (etypecase binding +;;; (rest-function-argument 'list) +;;; (supplied-p-function-argument 'boolean) +;;; (function-argument t)))))) +;;; ((and (consp type) (eq 'binding-type (car type))) +;;; (break "Got binding-type.") +;;; (let ((target-binding (binding-target (cadr type)))) +;;; (cond +;;; ((eq binding target-binding)) +;;; ((typep binding 'constant-object-binding) +;;; (setf (type-analysis-encoded-type analysis) +;;; (multiple-value-list +;;; (multiple-value-call +;;; #'encoded-types-or +;;; (values-list (type-analysis-encoded-type analysis)) +;;; (member-type-encode (constant-object target-binding)))))) +;;; (t (pushnew target-binding (type-analysis-binding-types analysis)) +;;; )))) ((and (bindingp type) (binding-eql type binding)) + (break "got binding type") nil) (t (setf (type-analysis-encoded-type analysis) (multiple-value-list (multiple-value-call #'encoded-types-or (values-list (type-analysis-encoded-type analysis)) - (type-specifier-encode type)))))))) + (type-specifier-encode type))))))) + #+ignore + (when (typep binding 'forwarding-binding) + (analyze-store (forwarding-binding-target binding) type thunk thunk-args))) (analyze-code (code) (dolist (instruction code) (when (listp instruction) (multiple-value-bind (store-binding store-type thunk thunk-args) (find-written-binding-and-type instruction) (when store-binding - (analyze-store (binding-target store-binding) store-type thunk thunk-args))) + #+ignore + (warn "store: ~S binding ~S type ~S thunk ~S" + instruction store-binding store-type thunk) + (analyze-store store-binding store-type thunk thunk-args))) (analyze-code (instruction-sub-program instruction))))) (analyze-funobj (funobj) (loop for (nil . function-env) in (function-envs funobj) @@ -448,88 +475,78 @@ ;; 1. Examine each store to lexical bindings. (analyze-funobj toplevel-funobj) ;; 2. - (loop repeat 10 while more-binding-references-p - doing - (setf more-binding-references-p nil) - (maphash (lambda (binding analysis) - (setf (type-analysis-thunks analysis) - (remove-if (lambda (x) - (destructuring-bind (thunk . thunk-args) x - (when (every (lambda (arg) - (or (not (bindingp arg)) - (binding-resolved-p arg))) - thunk-args) - (setf more-binding-references-p t) - (setf (type-analysis-encoded-type analysis) + (flet ((resolve-thunks () + (loop with more-thunks-p = t + repeat 20 + finally (return t) + do (unless more-thunks-p + (return nil)) + (setf more-thunks-p nil) + (maphash (lambda (binding analysis) + (declare (ignore binding)) + (setf (type-analysis-thunks analysis) + (loop for (thunk . thunk-args) in (type-analysis-thunks analysis) + if (not (every #'binding-resolved-p thunk-args)) + collect (cons thunk thunk-args) + else + do (setf (type-analysis-encoded-type analysis) (multiple-value-list (multiple-value-call - #'encoded-types-or + #'encoded-types-and (values-list - (type-analysis-encoded-type analysis)) - (type-specifier-encode - (apply thunk (mapcar #'binding-resolve - thunk-args))))))))) - (type-analysis-thunks analysis))) - (dolist (target-binding (type-analysis-binding-types analysis)) - (let* ((target-analysis - (or (gethash target-binding binding-usage) - (and (typep target-binding 'function-argument) - (make-type-analysis - :encoded-type (multiple-value-list - (type-specifier-encode t)))) - (error "Type-reference by ~S to unknown binding ~S" - binding target-binding))) - (new-type (setf (type-analysis-encoded-type analysis) - (multiple-value-list - (multiple-value-call - #'encoded-types-or - (values-list - (type-analysis-encoded-type analysis)) - (values-list - (type-analysis-encoded-type target-analysis))))))) - (cond - ((apply #'encoded-allp new-type) - ;; If the type is already T, no need to look further. - (setf (type-analysis-binding-types analysis) nil)) - ((setf (type-analysis-binding-types analysis) - (remove target-binding - (remove binding - (union (type-analysis-binding-types analysis) - (type-analysis-binding-types target-analysis))))) - (setf more-binding-references-p t)))))) - binding-usage)) - (when more-binding-references-p - (warn "Unable to remove all binding-references during lexical type analysis.")) + (type-analysis-declared-encoded-type analysis)) + (multiple-value-call + #'encoded-types-or + (values-list + (type-analysis-encoded-type analysis)) + (type-specifier-encode + (apply thunk (mapcar #'binding-resolve + thunk-args))))))) + (setf more-thunks-p t)))) + binding-usage)))) + (when (and (resolve-thunks) + *compiler-trust-user-type-declarations-p*) + ;; For each unresolved binding, just use the declared type. + (maphash (lambda (binding analysis) + (declare (ignore binding)) + (when (and (not (null (type-analysis-thunks analysis))) + (not (apply #'encoded-allp + (type-analysis-declared-encoded-type analysis)))) + (setf (type-analysis-encoded-type analysis) + (type-analysis-declared-encoded-type analysis)) + (setf (type-analysis-thunks analysis) nil))) ; Ignore remaining thunks. + binding-usage) + ;; Try one more time to resolve thunks. + (resolve-thunks))) + #+ignore + (maphash (lambda (binding analysis) + (when (type-analysis-thunks analysis) + (warn "Unable to infer type for ~S: ~S" binding + (type-analysis-thunks analysis)))) + binding-usage) ;; 3. (maphash (lambda (binding analysis) -;;; (loop for (nil . thunk-args) in (type-analysis-thunks analysis) -;;; do (warn "Unable to thunk ~S with args ~S." binding thunk-args)) - (assert (null (type-analysis-binding-types analysis)) () - "binding ~S type ~S still refers to ~S" - binding - (apply #'encoded-type-decode (type-analysis-encoded-type analysis)) - (type-analysis-binding-types analysis)) (setf (binding-store-type binding) (cond + ((and (not (null (type-analysis-thunks analysis))) + *compiler-trust-user-type-declarations-p* + (movitz-env-get (binding-name binding) :variable-type nil + (binding-env binding) nil)) + (multiple-value-list + (type-specifier-encode (movitz-env-get (binding-name binding) :variable-type + t (binding-env binding) nil)))) + ((and *compiler-trust-user-type-declarations-p* + (movitz-env-get (binding-name binding) :variable-type nil + (binding-env binding) nil)) + (multiple-value-list + (multiple-value-call #'encoded-types-and + (type-specifier-encode (movitz-env-get (binding-name binding) :variable-type + t (binding-env binding) nil)) + (values-list (type-analysis-encoded-type analysis))))) ((not (null (type-analysis-thunks analysis))) -;;; (when (not (rest (type-analysis-thunks analysis))) -;;; (warn "One thunk: ~S for ~S" binding (first (type-analysis-thunks analysis)))) (multiple-value-list (type-specifier-encode t))) (t (type-analysis-encoded-type analysis)))) - #+ignore - (when (apply #'encoded-type-singleton (type-analysis-encoded-type analysis)) - (warn "Singleton: ~A" binding)) - #+ignore - (when (or t #+ignore (not (apply #'encoded-allp (type-analysis-encoded-type analysis))) - #+ignore (multiple-value-call #'encoded-subtypep - (values-list (type-analysis-encoded-type analysis)) - (type-specifier-encode 'list))) - (warn "Type: ~S => ~A (~A)" - binding - (apply #'encoded-type-decode (type-analysis-encoded-type analysis)) - (multiple-value-call #'encoded-subtypep - (values-list (type-analysis-encoded-type analysis)) - (type-specifier-encode 'list))))) + #+ignore (warn "Finally: ~S" binding)) binding-usage)))) toplevel-funobj) @@ -555,10 +572,9 @@ 'forwarding-binding) (change-class (borrowed-binding-target borrowing-binding) 'located-binding)) - #+ignore - (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)) +;;; (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)) (dolist (usage usages) @@ -5821,24 +5837,28 @@ (list extended-instruction) (let* ((operator (car extended-instruction)) (expander (gethash operator *extended-code-expanders*))) - (if expander - (funcall expander extended-instruction funobj frame-map) - (list extended-instruction))))) + (if (not expander) + (list extended-instruction) + (let ((expansion (funcall expander extended-instruction funobj frame-map))) + (mapcan (lambda (e) + (expand-extended-code e funobj frame-map)) + expansion)))))) (defun ensure-local-binding (binding funobj) "When referencing binding in funobj, ensure we have the binding local to funobj." (if (not (typep binding 'binding)) binding - (let ((binding (binding-target binding))) + (let ((target-binding (binding-target binding))) (cond - ((eq funobj (binding-funobj binding)) + ((eq funobj (binding-funobj target-binding)) binding) - (t (or (find binding (borrowed-bindings funobj) + (t (or (find target-binding (borrowed-bindings funobj) :key (lambda (binding) (borrowed-binding-target binding))) (error "Can't install non-local binding ~W." binding))))))) (defun binding-type-specifier (binding) + (break "nix binding-type-specifier: ~S" binding) (etypecase binding (forwarding-binding (binding-type-specifier (forwarding-binding-target binding))) @@ -5867,7 +5887,10 @@ (destructuring-bind (source destination &key &allow-other-keys) (cdr instruction) (when (typep destination 'binding) - (values destination (binding-type-specifier source))))) + (values destination t #+ignore (binding-type-specifier source) + (lambda (source-type) + source-type) + (list source))))) (define-find-read-bindings :load-lexical (source destination &key &allow-other-keys) (declare (ignore destination)) @@ -5927,8 +5950,13 @@ (declare (ignore protect-registers protect-carry)) (cond (init-with-register - (assert init-with-type) - (values binding init-with-type)) + (cond + ((not (typep init-with-register 'binding)) + (assert init-with-type) + (values binding init-with-type) ) + (t (values binding t + (lambda (x) x) + (list init-with-register))))) ((not (typep binding 'temporary-name)) (values binding t))))) @@ -5942,8 +5970,6 @@ init-with-register init-with-type) (cdr instruction) (declare (ignore protect-carry)) ; nothing modifies carry anyway. - (when (string= (binding-name binding) 'reader-function) - (break "init: ~S" instruction)) ;; (assert (eq binding (ensure-local-binding binding funobj))) (assert (eq funobj (binding-funobj binding))) (cond @@ -6049,6 +6075,8 @@ (:movl ,tmp-register (:ebp ,(stack-frame-offset (new-binding-location binding frame-map)))))))) + ((typep init-with-register 'lexical-binding) + (make-load-lexical init-with-register binding funobj nil frame-map)) (init-with-register (make-store-lexical binding init-with-register nil frame-map)))))))) @@ -6239,41 +6267,59 @@ (bindingp term1) (member (result-mode-type destination) '(:lexical-binding :function :multple-values :eax :ebx :ecx :edx)))) - (let* ((term0 (binding-target term0)) - (term1 (binding-target term1)) - (destination (if (or (not (bindingp destination)) - (not (symbolp (new-binding-location destination frame-map :default 0)))) - destination - (new-binding-location destination frame-map))) + (let* ((destination (ensure-local-binding destination funobj)) + (term0 (ensure-local-binding term0 funobj)) + (term1 (ensure-local-binding term1 funobj)) + (destination-location (if (or (not (bindingp destination)) + (typep destination 'borrowed-binding)) + destination + (new-binding-location (binding-target destination) frame-map))) (type0 (apply #'encoded-type-decode (binding-store-type term0))) (type1 (apply #'encoded-type-decode (binding-store-type term1))) (result-type (multiple-value-call #'encoded-integer-types-add (values-list (binding-store-type term0)) (values-list (binding-store-type term1))))) - ;; (warn "add for: ~S is ~A." destination result-type) (let ((loc0 (new-binding-location term0 frame-map :default nil)) (loc1 (new-binding-location term1 frame-map :default nil))) +;;; (warn "add: ~A" instruction) +;;; (warn "add for: ~S is ~A, from ~A/~A and ~A/~A." +;;; destination result-type +;;; term0 loc0 +;;; term1 loc1) (cond ((type-specifier-singleton result-type) ;; (break "constant add: ~S" instruction) (make-load-constant (car (type-specifier-singleton result-type)) destination funobj frame-map)) - ((and (movitz-subtypep type1 'fixnum) + ((and (movitz-subtypep type0 'fixnum) (movitz-subtypep type1 'fixnum) (movitz-subtypep result-type 'fixnum)) (cond ((and (type-specifier-singleton type0) - (eq loc1 destination)) + (eq loc1 destination-location)) (cond - ((member destination '(:eax :ebx :ecx :edx)) + ((member destination-location '(:eax :ebx :ecx :edx)) `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) ,destination))) (t (assert (integerp loc1)) (break "check that this is correct..") `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) (:ebp ,(stack-frame-offset loc1))))))) + ((and (type-specifier-singleton type0) + (eq term1 destination) + (integerp destination-location)) + (break "untested") + `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) + (:ebp ,(stack-frame-offset destination-location))))) + ((and (type-specifier-singleton type0) + (symbolp loc1) + (integerp destination-location)) + `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) + ,loc1) + (:movl ,loc1 (:ebp ,(stack-frame-offset destination-location))))) (t -;;; (warn "ADD: ~S = ~A/~S + ~A/~S,~%~A ~A" +;;; (warn "ADD: ~A/~S = ~A/~S + ~A/~S,~%~A ~A" +;;; destination-location ;;; destination ;;; loc0 term0 ;;; loc1 term1 @@ -6281,24 +6327,24 @@ ;;; (eq loc1 destination)) ;;; (warn "ADDI: ~S" instruction) (append (cond - ((and (eq :eax loc0) (eq :ebx loc1)) - nil) - ((and (eq :ebx loc0) (eq :eax loc1)) - nil) ; terms order isn't important - ((eq :eax loc1) - (append - (make-load-lexical term0 :ebx funobj nil frame-map))) - (t (append - (make-load-lexical term0 :eax funobj nil frame-map) - (make-load-lexical term1 :ebx funobj nil frame-map)))) - `((:movl (:edi ,(global-constant-offset '+)) :esi)) - (make-compiled-funcall-by-esi 2) - (etypecase destination - (symbol - (unless (eq destination :eax) - `((:movl :eax ,destination)))) - (binding - (make-store-lexical destination :eax nil frame-map))))))) + ((and (eq :eax loc0) (eq :ebx loc1)) + nil) + ((and (eq :ebx loc0) (eq :eax loc1)) + nil) ; terms order isn't important + ((eq :eax loc1) + (append + (make-load-lexical term0 :ebx funobj nil frame-map))) + (t (append + (make-load-lexical term0 :eax funobj nil frame-map) + (make-load-lexical term1 :ebx funobj nil frame-map)))) + `((:movl (:edi ,(global-constant-offset '+)) :esi)) + (make-compiled-funcall-by-esi 2) + (etypecase destination + (symbol + (unless (eq destination :eax) + `((:movl :eax ,destination)))) + (binding + (make-store-lexical destination :eax nil frame-map))))))) (t (append (cond ((and (eq :eax loc0) (eq :ebx loc1)) nil) From ffjeld at common-lisp.net Thu Aug 12 17:26:49 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 12 Aug 2004 10:26:49 -0700 Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv3367 Modified Files: special-operators-cl.lisp Log Message: Changed the way let installs lexical variables. This code is so ugly, but it's too much work to make it neat. Date: Thu Aug 12 10:26:49 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.20 movitz/special-operators-cl.lisp:1.21 --- movitz/special-operators-cl.lisp:1.20 Wed Jul 21 05:19:15 2004 +++ movitz/special-operators-cl.lisp Thu Aug 12 10:26:49 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.20 2004/07/21 12:19:15 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.21 2004/08/12 17:26:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -98,7 +98,8 @@ ;; lexical... else collect (compiler-values-bind (&code init-code &functional-p functional-p - &type type &returns init-register) + &type type &returns init-register + &final-form final-form) (compiler-call #'compile-form-to-register :env init-env :defaults all @@ -115,7 +116,8 @@ init-type) (case init-register (:non-local-exit :edi) - (t init-register)))) + (t init-register)) + final-form)) and do (movitz-env-add-binding local-env (make-instance 'located-binding :name var))))) (setf (stack-used local-env) @@ -172,7 +174,8 @@ )) (t (let ((code (append (loop - for ((var init-form init-code functional-p type init-register) + for ((var init-form init-code functional-p type init-register + final-form) . rest-codes) on binding-var-codes as binding = (movitz-binding var local-env nil) @@ -182,12 +185,12 @@ (assert (not (binding-lended-p binding))) appending (cond - ;; #+ignore ((and (typep binding 'located-binding) (not (binding-lended-p binding)) - (= 1 (length init-code)) - (eq :load-lexical (first (first init-code))) - (let* ((target-binding (second (first init-code)))) +;;; (= 1 (length init-code)) +;;; (eq :load-lexical (first (first init-code))) + (typep final-form 'lexical-binding) + (let ((target-binding final-form)) (and (typep target-binding 'lexical-binding) (eq (binding-funobj binding) (binding-funobj target-binding)) @@ -247,23 +250,39 @@ ((typep binding 'lexical-binding) (let ((init (type-specifier-singleton (type-specifier-primary type)))) - (if (and init (eq *movitz-nil* (car init))) - (append (if functional-p - nil - (compiler-call #'compile-form-unprotected - :env init-env - :defaults all - :form init-form - :result-mode :ignore - :modify-accumulate let-modifies)) - `((:init-lexvar ,binding - :init-with-register :edi - :init-with-type null))) - (append init-code - `((:init-lexvar - ,binding - :init-with-register ,init-register - :init-with-type ,(type-specifier-primary type))))))) + (cond + ((and init (eq *movitz-nil* (car init))) + (append (if functional-p + nil + (compiler-call #'compile-form-unprotected + :env init-env + :defaults all + :form init-form + :result-mode :ignore + :modify-accumulate let-modifies)) + `((:init-lexvar ,binding + :init-with-register :edi + :init-with-type null)))) + ((and (typep final-form 'lexical-binding) + (eq (binding-funobj final-form) + funobj)) + (append (if functional-p + nil + (compiler-call #'compile-form-unprotected + :env init-env + :defaults all + :form init-form + :result-mode :ignore + :modify-accumulate let-modifies)) + `((:init-lexvar ,binding + :init-with-register ,final-form + ;; :init-with-type ,final-form + )))) + (t (append init-code + `((:init-lexvar + ,binding + :init-with-register ,init-register + :init-with-type ,(type-specifier-primary type)))))))) (t init-code))) (when (plusp (num-specials local-env)) `((:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))) From ffjeld at common-lisp.net Thu Aug 12 17:45:40 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 12 Aug 2004 10:45:40 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv32161 Modified Files: debugger.lisp Log Message: Change from interrupt-frame-ref to dit-frame-ref, etc. Date: Thu Aug 12 10:45:39 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.20 movitz/losp/x86-pc/debugger.lisp:1.21 --- movitz/losp/x86-pc/debugger.lisp:1.20 Fri Aug 6 07:47:41 2004 +++ movitz/losp/x86-pc/debugger.lisp Thu Aug 12 10:45:39 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.20 2004/08/06 14:47:41 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.21 2004/08/12 17:45:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -472,7 +472,7 @@ (typecase funobj (integer (let* ((interrupt-frame stack-frame) - (funobj (interrupt-frame-ref :esi :lisp 0 interrupt-frame))) + (funobj (dit-frame-ref :esi :lisp 0 interrupt-frame))) (if (and conflate-interrupts conflate ;; When the interrupted function has a stack-frame, conflate it. (typep funobj 'function) @@ -482,9 +482,9 @@ (incf count) (print-leadin stack-frame count conflate-count) (setf conflate-count 0) - (let ((exception (interrupt-frame-ref :exception :unsigned-byte32 + (let ((exception (dit-frame-ref :exception-vector :unsigned-byte32 0 interrupt-frame)) - (eip (interrupt-frame-ref :eip :unsigned-byte32 + (eip (dit-frame-ref :eip :unsigned-byte32 0 interrupt-frame))) (typecase funobj (function From ffjeld at common-lisp.net Sat Aug 14 17:45:18 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 14 Aug 2004 10:45:18 -0700 Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv27626 Modified Files: special-operators.lisp Log Message: Removed unused special operator make-prototyped-function. Fixed special operator define-prototyped-function to copy the functions code-vectors properly. The old way caused significant overhead in prototyped functions, such as struct accessors. Date: Sat Aug 14 10:45:17 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.35 movitz/special-operators.lisp:1.36 --- movitz/special-operators.lisp:1.35 Tue Aug 10 06:28:05 2004 +++ movitz/special-operators.lisp Sat Aug 14 10:45:17 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.35 2004/08/10 13:28:05 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.36 2004/08/14 17:45:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -290,10 +290,12 @@ (destructuring-bind (function-name proto-name &rest parameters) (cdr form) (let* ((funobj-proto (movitz-env-named-function proto-name)) - (code-vector (movitz-funobj-code-vector funobj-proto)) (funobj (make-instance 'movitz-funobj :name (movitz-read function-name) - :code-vector code-vector + :code-vector (movitz-funobj-code-vector funobj-proto) + :code-vector%1op (movitz-funobj-code-vector%1op funobj-proto) + :code-vector%2op (movitz-funobj-code-vector%2op funobj-proto) + :code-vector%3op (movitz-funobj-code-vector%3op funobj-proto) :lambda-list (movitz-funobj-lambda-list funobj-proto) :num-constants (movitz-funobj-num-constants funobj-proto) :num-jumpers (movitz-funobj-num-jumpers funobj-proto) @@ -317,32 +319,6 @@ (setf (movitz-funobj-symbolic-name funobj) function-name) (setf (movitz-env-named-function function-name) funobj) (compiler-values ())))) - -(define-special-operator make-prototyped-function (&all forward &form form) - (destructuring-bind (function-name proto-name &rest parameters) - (cdr form) - (let* ((funobj-proto (movitz-env-named-function proto-name)) - (code-vector (movitz-funobj-code-vector funobj-proto)) - (funobj (make-instance 'movitz-funobj - :name (movitz-read function-name) - :code-vector code-vector - :lambda-list (movitz-funobj-lambda-list funobj-proto) - :num-constants (movitz-funobj-num-constants funobj-proto) - :symbolic-code (when (slot-boundp funobj-proto 'symbolic-code) - (movitz-funobj-symbolic-code funobj-proto)) - :const-list (let ((c (copy-list (movitz-funobj-const-list funobj-proto)))) - (loop for (lisp-parameter value) in parameters - as parameter = (movitz-read lisp-parameter) - do (assert (member parameter c) () - "~S is not a function prototype parameter for ~S. ~ -The valid parameters are~{ ~S~}." - parameter proto-name - (mapcar #'movitz-print (movitz-funobj-const-list funobj-proto))) - do (setf (car (member parameter c)) (movitz-read value))) - c)))) - (compiler-call #'compile-self-evaluating - :form funobj - :forward forward)))) (define-special-operator define-setf-expander-compile-time (&form form) (destructuring-bind (access-fn lambda-list macro-body) From ffjeld at common-lisp.net Sat Aug 14 17:47:04 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 14 Aug 2004 10:47:04 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv21538 Modified Files: compiler.lisp Log Message: More tuning of type inference. Date: Sat Aug 14 10:47:04 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.93 movitz/compiler.lisp:1.94 --- movitz/compiler.lisp:1.93 Thu Aug 12 10:25:06 2004 +++ movitz/compiler.lisp Sat Aug 14 10:47:04 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.93 2004/08/12 17:25:06 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.94 2004/08/14 17:47:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -415,33 +415,7 @@ (cond (thunk (assert (some #'bindingp thunk-args)) -;;; (assert (notany (lambda (arg) -;;; (and (bindingp arg) -;;; (binding-eql arg binding))) -;;; thunk-args) -;;; () "A thunk on itself for ~S?" binding) (push (cons thunk thunk-args) (type-analysis-thunks analysis))) -;;; ((typep binding 'function-argument) -;;; (setf (type-analysis-encoded-type analysis) -;;; (multiple-value-list -;;; (type-specifier-encode (etypecase binding -;;; (rest-function-argument 'list) -;;; (supplied-p-function-argument 'boolean) -;;; (function-argument t)))))) -;;; ((and (consp type) (eq 'binding-type (car type))) -;;; (break "Got binding-type.") -;;; (let ((target-binding (binding-target (cadr type)))) -;;; (cond -;;; ((eq binding target-binding)) -;;; ((typep binding 'constant-object-binding) -;;; (setf (type-analysis-encoded-type analysis) -;;; (multiple-value-list -;;; (multiple-value-call -;;; #'encoded-types-or -;;; (values-list (type-analysis-encoded-type analysis)) -;;; (member-type-encode (constant-object target-binding)))))) -;;; (t (pushnew target-binding (type-analysis-binding-types analysis)) -;;; )))) ((and (bindingp type) (binding-eql type binding)) (break "got binding type") @@ -451,10 +425,7 @@ (multiple-value-call #'encoded-types-or (values-list (type-analysis-encoded-type analysis)) - (type-specifier-encode type))))))) - #+ignore - (when (typep binding 'forwarding-binding) - (analyze-store (forwarding-binding-target binding) type thunk thunk-args))) + (type-specifier-encode type)))))))) (analyze-code (code) (dolist (instruction code) (when (listp instruction) @@ -478,10 +449,8 @@ (flet ((resolve-thunks () (loop with more-thunks-p = t repeat 20 - finally (return t) - do (unless more-thunks-p - (return nil)) - (setf more-thunks-p nil) + while more-thunks-p + do (setf more-thunks-p nil) (maphash (lambda (binding analysis) (declare (ignore binding)) (setf (type-analysis-thunks analysis) @@ -504,8 +473,8 @@ thunk-args))))))) (setf more-thunks-p t)))) binding-usage)))) - (when (and (resolve-thunks) - *compiler-trust-user-type-declarations-p*) + (resolve-thunks) + (when *compiler-trust-user-type-declarations-p* ;; For each unresolved binding, just use the declared type. (maphash (lambda (binding analysis) (declare (ignore binding)) From ffjeld at common-lisp.net Sat Aug 14 17:52:35 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 14 Aug 2004 10:52:35 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/lib/misc.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv22180 Modified Files: misc.lisp Log Message: Fixed checksum-octets to observe register discipline. Date: Sat Aug 14 10:52:35 2004 Author: ffjeld Index: movitz/losp/lib/misc.lisp diff -u movitz/losp/lib/misc.lisp:1.4 movitz/losp/lib/misc.lisp:1.5 --- movitz/losp/lib/misc.lisp:1.4 Thu Feb 26 03:40:00 2004 +++ movitz/losp/lib/misc.lisp Sat Aug 14 10:52:35 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon May 12 17:13:31 2003 ;;;; -;;;; $Id: misc.lisp,v 1.4 2004/02/26 11:40:00 ffjeld Exp $ +;;;; $Id: misc.lisp,v 1.5 2004/08/14 17:52:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -24,29 +24,31 @@ (typecase packet (muerte:vector-u8 (assert (<= 0 start end (length packet))) - (with-inline-assembly (:returns :ebx) - (:compile-form (:result-mode :eax) packet) - (:compile-form (:result-mode :ebx) start) - (:compile-form (:result-mode :edx) end) - (:movl :ebx :ecx) ; ecx = start - (:subl :ebx :edx) ; edx = (- end start) - (:movl 0 :ebx) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :ebx) packet) + (:compile-form (:result-mode :eax) start) + (:compile-form (:result-mode :esi) end) + (:movl :eax :ecx) ; ecx = start + (:subl :eax :esi) ; esi = (- end start) + (:movl 0 :eax) (:jz 'end-checksum-loop) (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) - (:xorl :esi :esi) + (:xorl :edx :edx) + (:std) checksum-loop - (:movw (:eax 2 :ecx) :bx) - (:xchgb :bl :bh) - (:addl :ebx :esi) + (:movw (:ebx 2 :ecx) :ax) + (:xchgb :al :ah) (:addl 2 :ecx) - (:subl #.(cl:* 2 movitz:+movitz-fixnum-factor+) :edx) + (:addl :eax :edx) + (:subl #.(cl:* 2 movitz:+movitz-fixnum-factor+) :esi) (:jnbe 'checksum-loop) - (:movw :si :bx) - (:shrl 16 :esi) - (:addw :si :bx) - (:movl (:ebp -4) :esi) + (:movw :dx :ax) + (:shrl 16 :edx) + (:addw :dx :ax) + (:movl (:ebp -4) :esi) end-checksum-loop - (:shll #.movitz:+movitz-fixnum-shift+ :ebx))) + (:shll #.movitz:+movitz-fixnum-shift+ :eax) + (:cld))) (t (muerte:with-subvector-accessor (packet-ref packet start end) (cond ((or (and (evenp start) (evenp end)) From ffjeld at common-lisp.net Sat Aug 14 17:53:25 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 14 Aug 2004 10:53:25 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv28768 Modified Files: basic-macros.lisp Log Message: Tried to fix let* to do the right thing with declarations. Date: Sat Aug 14 10:53:25 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.36 movitz/losp/muerte/basic-macros.lisp:1.37 --- movitz/losp/muerte/basic-macros.lisp:1.36 Sat Jul 31 17:37:26 2004 +++ movitz/losp/muerte/basic-macros.lisp Sat Aug 14 10:53:25 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.36 2004/08/01 00:37:26 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.37 2004/08/14 17:53:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -159,15 +159,18 @@ (push ',name (movitz::image-compile-time-variables movitz::*image*)))) (defvar ,name 'uninitialized-compile-time-variable)))) -(defmacro let* (var-list &body body) - (labels ((expand (rest-vars body) - (if (null rest-vars) - body - `((let (,(car rest-vars)) - ,@(expand (cdr rest-vars) body)))))) - (if (endp var-list) - `(let () , at body) - (car (expand var-list body))))) +(defmacro let* (var-list &body declarations-and-body) + (multiple-value-bind (body declarations) + (movitz::parse-declarations-and-body declarations-and-body 'cl:declare) + (labels ((expand (rest-vars body) + (if (null rest-vars) + body + `((let (,(car rest-vars)) + (declare , at declarations) + ,@(expand (cdr rest-vars) body)))))) + (if (endp var-list) + `(let () , at body) + (car (expand var-list body)))))) (defmacro or (&rest forms) (cond From ffjeld at common-lisp.net Sat Aug 14 17:55:29 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 14 Aug 2004 10:55:29 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cpu-id.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18049 Modified Files: cpu-id.lisp Log Message: Fix eflags to observe stack and register discipline. Date: Sat Aug 14 10:55:29 2004 Author: ffjeld Index: movitz/losp/muerte/cpu-id.lisp diff -u movitz/losp/muerte/cpu-id.lisp:1.8 movitz/losp/muerte/cpu-id.lisp:1.9 --- movitz/losp/muerte/cpu-id.lisp:1.8 Thu Aug 12 08:42:59 2004 +++ movitz/losp/muerte/cpu-id.lisp Sat Aug 14 10:55:29 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Apr 15 22:47:13 2002 ;;;; -;;;; $Id: cpu-id.lisp,v 1.8 2004/08/12 15:42:59 ffjeld Exp $ +;;;; $Id: cpu-id.lisp,v 1.9 2004/08/14 17:55:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -215,11 +215,10 @@ (:wrmsr))) (define-compiler-macro eflags () - `(with-inline-assembly (:returns :register) - ;; XXXXX Breaks stack and register disciplines! + `(with-inline-assembly (:returns :untagged-fixnum-ecx) + (:clc) ; Ensure lower 2 bits are zero.. (:pushfl) - (:popl (:result-register)) - (:shll 2 (:result-register)))) + (:popl :ecx))) (defun eflags () (eflags)) From ffjeld at common-lisp.net Mon Aug 16 08:24:57 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 16 Aug 2004 01:24:57 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24962 Modified Files: compiler.lisp Log Message: Make the compiler work when *compiler-do-type-inference* is NIL. Fixed a bug in the :add extended-code expander; it didn't work well for lended bindings. Date: Mon Aug 16 01:24:56 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.94 movitz/compiler.lisp:1.95 --- movitz/compiler.lisp:1.94 Sat Aug 14 10:47:04 2004 +++ movitz/compiler.lisp Mon Aug 16 01:24:56 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.94 2004/08/14 17:47:04 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.95 2004/08/16 08:24:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -72,7 +72,7 @@ "Spend time and effort performing type inference and optimization.") (defvar *compiler-produce-defensive-code* t - "Try make code be extra cautious.") + "Try to make code be extra cautious.") (defvar *compiler-trust-user-type-declarations-p* t) @@ -381,7 +381,24 @@ (defun analyze-bindings (toplevel-funobj) "Figure out usage of bindings in a toplevel funobj. Side-effects each binding's binding-store-type." - (when *compiler-do-type-inference* + (if (not *compiler-do-type-inference*) + (labels + ((analyze-code (code) + (dolist (instruction code) + (when (listp instruction) + (let ((binding + (find-written-binding-and-type instruction))) + (when binding + (setf (binding-store-type binding) + (multiple-value-list (type-specifier-encode t))))) + (analyze-code (instruction-sub-program instruction))))) + (analyze-funobj (funobj) + (loop for (nil . function-env) in (function-envs funobj) + do (analyze-code (extended-code function-env))) + (loop for function-binding in (sub-function-binding-usage funobj) by #'cddr + do (analyze-funobj (function-binding-funobj function-binding))) + funobj)) + (analyze-funobj toplevel-funobj)) (let ((binding-usage (make-hash-table :test 'eq))) (labels ((binding-resolved-p (binding) (let ((analysis (gethash binding binding-usage))) @@ -6283,9 +6300,9 @@ ((and (type-specifier-singleton type0) (symbolp loc1) (integerp destination-location)) - `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) - ,loc1) - (:movl ,loc1 (:ebp ,(stack-frame-offset destination-location))))) + (append `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) + ,loc1)) + (make-store-lexical destination loc1 nil frame-map))) (t ;;; (warn "ADD: ~A/~S = ~A/~S + ~A/~S,~%~A ~A" ;;; destination-location From ffjeld at common-lisp.net Mon Aug 16 08:25:29 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 16 Aug 2004 01:25:29 -0700 Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv32160 Modified Files: procfs-image.lisp Log Message: Minor tweam of procfs debugging. Date: Mon Aug 16 01:25:29 2004 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.15 movitz/procfs-image.lisp:1.16 --- movitz/procfs-image.lisp:1.15 Thu Aug 12 08:42:00 2004 +++ movitz/procfs-image.lisp Mon Aug 16 01:25:28 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.15 2004/08/12 15:42:00 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.16 2004/08/16 08:25:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -179,7 +179,7 @@ ((or movitz-funobj movitz-struct movitz-std-instance) object) (t (movitz-print object)))) - (t (c) (list :word-error word c))))) + (serious-condition (c) (list :word-error word c))))) (defun backtrace (&key (reqs t) print-frames print-returns spartan) (format t "~&Backtracing from EIP = #x~X: " From ffjeld at common-lisp.net Mon Aug 16 08:26:42 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 16 Aug 2004 01:26:42 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9984 Modified Files: sequences.lisp Log Message: Added a type declaration. Date: Mon Aug 16 01:26:41 2004 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.16 movitz/losp/muerte/sequences.lisp:1.17 --- movitz/losp/muerte/sequences.lisp:1.16 Thu Aug 12 10:01:26 2004 +++ movitz/losp/muerte/sequences.lisp Mon Aug 16 01:26:40 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.16 2004/08/12 17:01:26 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.17 2004/08/16 08:26:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -74,7 +74,8 @@ (list (do ((x sequence (cdr x)) (length 0 (1+ length))) - ((null x) length))))) + ((null x) length) + (declare (index length)))))) (defun length%list (sequence) (do ((length 0 (1+ length)) From ffjeld at common-lisp.net Mon Aug 16 15:26:36 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 16 Aug 2004 08:26:36 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7880 Modified Files: integers.lisp Log Message: Fixed complicated-eql, which was very broken for bignums. And therefore = was also broken. And therefore also - and many other operators. Date: Mon Aug 16 08:26:36 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.91 movitz/losp/muerte/integers.lisp:1.92 --- movitz/losp/muerte/integers.lisp:1.91 Wed Aug 4 05:59:23 2004 +++ movitz/losp/muerte/integers.lisp Mon Aug 16 08:26:36 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.91 2004/08/04 12:59:23 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.92 2004/08/16 15:26:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -159,7 +159,7 @@ (:jne 'done) ;; Ok.. we have two bignums of identical sign and size. (:shrl 16 :ecx) - (:movl :ecx :edx) ; counter + (:leal (:ecx 4) :edx) ; counter compare-loop (:subl ,movitz:+movitz-fixnum-factor+ :edx) (:jz 'done) @@ -187,39 +187,6 @@ (:movl :edi :eax) (:clc) ))) - (do-it))) - - -(define-primitive-function fast-eql (x y) - "Compare EAX and EBX under EQL, result in ZF. -Preserve EAX and EBX." - (macrolet - ((do-it () - `(with-inline-assembly (:returns :nothing) ; unspecified - (:cmpl :eax :ebx) ; EQ? - (:je 'done) - (:leal (:eax ,(- (movitz:tag :other))) :ecx) - (:testb 7 :cl) - (:jne 'done) - (:leal (:ebx ,(- (movitz:tag :other))) :ecx) - (:testb 7 :cl) - (:jne 'done) - (:movl (:eax ,movitz:+other-type-offset+) :ecx) - (:cmpb ,(movitz:tag :bignum) :cl) - (:jne 'done) - (:cmpl :ecx (:ebx ,movitz:+other-type-offset+)) - (:jne 'done) - ;; Ok.. we have two bignums of identical sign and size. - (:shrl 16 :ecx) - (:movl :ecx :edx) ; counter - compare-loop - (:subl ,movitz:+movitz-fixnum-factor+ :edx) - (:jz 'done) - (:movl (:eax :edx (:offset movitz-bignum bigit0 -4)) :ecx) - (:cmpl :ecx (:ebx :edx (:offset movitz-bignum bigit0 -4))) - (:je 'compare-loop) - done - (:ret)))) (do-it))) (define-primitive-function fast-compare-fixnum-real (n1 n2) From ffjeld at common-lisp.net Mon Aug 16 15:28:07 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 16 Aug 2004 08:28:07 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30595 Modified Files: functions.lisp Log Message: Fixed funobj-code-vector%{1,2,3}op to not assume code-vectors are all #x100 bytes long, and to be somewhat resistant to GC activiy. Date: Mon Aug 16 08:28:07 2004 Author: ffjeld Index: movitz/losp/muerte/functions.lisp diff -u movitz/losp/muerte/functions.lisp:1.17 movitz/losp/muerte/functions.lisp:1.18 --- movitz/losp/muerte/functions.lisp:1.17 Tue Jul 20 05:58:34 2004 +++ movitz/losp/muerte/functions.lisp Mon Aug 16 08:28:07 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.17 2004/07/20 12:58:34 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.18 2004/08/16 15:28:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -115,24 +115,31 @@ as that vector." (check-type funobj function) (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) funobj) - (:movl (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) :ebx) ; EBX = code-vector - (:movl (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%1op)) :eax) ; EAX = code-vector%1op - ;; determine if EAX is a pointer into EBX - (:cmpl :ebx :eax) + retry + (:declare-label-set retry-jumper (retry)) + (:locally (:movl '(:funcall #.(movitz::atomically-status-jumper-fn t) + 'retry-jumper) + (:edi (:edi-offset atomically-status)))) + (:compile-form (:result-mode :ebx) funobj) + (:movl (:ebx (:offset movitz-funobj code-vector)) :eax) ; EAX = code-vector + (:movl (:ebx (:offset movitz-funobj code-vector%1op)) :ecx) + ;; determine if ECX is a pointer into EBX + (:subl :eax :ecx) (:jl 'return-vector) - (:andb #xf8 :bl) - (:addl #x100 :ebx) - (:cmpl :ebx :eax) + (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :ecx) + (:cmpl (:ebx (:offset movitz-basic-vector num-elements)) :ecx) (:jg 'return-vector) ;; return the integer offset EAX-EBX - (:subl #x100 :ebx) - (:subl :ebx :eax) - (:shll #.movitz:+movitz-fixnum-shift+ :eax) + (:movl :ecx :eax) (:jmp 'done) - return-vector - (:subl 2 :eax) - done)) ; this cell stores word+2 + return-vector + (:testl 7 (:ebx (:offset movitz-funobj code-vector%1op))) + (:jnz '(:sub-program () (:int 63))) + (:movl #xfffffffe :eax) + (:addl (:ebx (:offset movitz-funobj code-vector%1op)) :eax) + done + (:locally (:movl #.(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))))) ; this cell stores word+2 (defun (setf funobj-code-vector%1op) (code-vector funobj) (check-type funobj function) @@ -160,24 +167,31 @@ as that vector." (check-type funobj function) (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) funobj) - (:movl (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) :ebx) ; EBX = code-vector - (:movl (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%2op)) :eax) ; EAX = code-vector%1op - ;; determine if EAX is a pointer into EBX - (:cmpl :ebx :eax) + retry + (:declare-label-set retry-jumper (retry)) + (:locally (:movl '(:funcall #.(movitz::atomically-status-jumper-fn t) + 'retry-jumper) + (:edi (:edi-offset atomically-status)))) + (:compile-form (:result-mode :ebx) funobj) + (:movl (:ebx (:offset movitz-funobj code-vector)) :eax) ; EAX = code-vector + (:movl (:ebx (:offset movitz-funobj code-vector%2op)) :ecx) + ;; determine if ECX is a pointer into EBX + (:subl :eax :ecx) (:jl 'return-vector) - (:andb #xf8 :bl) - (:addl #x100 :ebx) - (:cmpl :ebx :eax) + (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :ecx) + (:cmpl (:ebx (:offset movitz-basic-vector num-elements)) :ecx) (:jg 'return-vector) ;; return the integer offset EAX-EBX - (:subl #x100 :ebx) - (:subl :ebx :eax) - (:shll #.movitz:+movitz-fixnum-shift+ :eax) + (:movl :ecx :eax) (:jmp 'done) - return-vector - (:subl 2 :eax) - done)) + return-vector + (:testl 7 (:ebx (:offset movitz-funobj code-vector%2op))) + (:jnz '(:sub-program () (:int 63))) + (:movl #xfffffffe :eax) + (:addl (:ebx (:offset movitz-funobj code-vector%2op)) :eax) + done + (:locally (:movl #.(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))))) (defun (setf funobj-code-vector%2op) (code-vector funobj) (check-type funobj function) @@ -205,24 +219,31 @@ as that vector." (check-type funobj function) (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) funobj) - (:movl (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) :ebx) ; EBX = code-vector - (:movl (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%3op)) :eax) ; EAX = code-vector%1op - ;; determine if EAX is a pointer into EBX - (:cmpl :ebx :eax) + retry + (:declare-label-set retry-jumper (retry)) + (:locally (:movl '(:funcall #.(movitz::atomically-status-jumper-fn t) + 'retry-jumper) + (:edi (:edi-offset atomically-status)))) + (:compile-form (:result-mode :ebx) funobj) + (:movl (:ebx (:offset movitz-funobj code-vector)) :eax) ; EAX = code-vector + (:movl (:ebx (:offset movitz-funobj code-vector%3op)) :ecx) + ;; determine if ECX is a pointer into EBX + (:subl :eax :ecx) (:jl 'return-vector) - (:andb #xf8 :bl) - (:addl #x100 :ebx) - (:cmpl :ebx :eax) + (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :ecx) + (:cmpl (:ebx (:offset movitz-basic-vector num-elements)) :ecx) (:jg 'return-vector) ;; return the integer offset EAX-EBX - (:subl #x100 :ebx) - (:subl :ebx :eax) - (:shll #.movitz:+movitz-fixnum-shift+ :eax) + (:movl :ecx :eax) (:jmp 'done) - return-vector - (:subl 2 :eax) - done)) + return-vector + (:testl 7 (:ebx (:offset movitz-funobj code-vector%3op))) + (:jnz '(:sub-program () (:int 63))) + (:movl #xfffffffe :eax) + (:addl (:ebx (:offset movitz-funobj code-vector%3op)) :eax) + done + (:locally (:movl #.(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))))) (defun (setf funobj-code-vector%3op) (code-vector funobj) (check-type funobj function) From ffjeld at common-lisp.net Mon Aug 16 23:15:12 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 16 Aug 2004 16:15:12 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18914 Modified Files: memref.lisp Log Message: Fixed (memref .. :character) used EBX in an undisciplined way. Date: Mon Aug 16 16:15:12 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.26 movitz/losp/muerte/memref.lisp:1.27 --- movitz/losp/muerte/memref.lisp:1.26 Thu Aug 12 10:00:29 2004 +++ movitz/losp/muerte/memref.lisp Mon Aug 16 16:15:12 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.26 2004/08/12 17:00:29 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.27 2004/08/16 23:15:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -187,11 +187,11 @@ (cond ((eq 0 offset) `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:ecx :ebx) ,object ,index) + (:compile-two-forms (:ebx :ecx) ,object ,index) (:xorl :eax :eax) (:movb ,(movitz:tag :character) :al) - (:sarl ,movitz::+movitz-fixnum-shift+ :ebx) ; scale index - (:movb (:ecx :ebx ,(offset-by 1)) :ah))) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale index + (:movb (:ebx :ecx ,(offset-by 1)) :ah))) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) (with-inline-assembly (:returns :eax) From ffjeld at common-lisp.net Wed Aug 18 09:15:16 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 18 Aug 2004 02:15:16 -0700 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv27437 Modified Files: image.lisp Log Message: Remove fast-eql from run-time-context. Date: Wed Aug 18 02:15:15 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.64 movitz/image.lisp:1.65 --- movitz/image.lisp:1.64 Tue Aug 10 06:25:16 2004 +++ movitz/image.lisp Wed Aug 18 02:15:14 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.64 2004/08/10 13:25:16 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.65 2004/08/18 09:15:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -265,12 +265,6 @@ :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) (fast-compare-real-fixnum - :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) - (fast-eql :binary-type code-vector-word :initform nil :map-binary-write 'movitz-intern-code-vector From ffjeld at common-lisp.net Wed Aug 18 09:27:57 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 18 Aug 2004 02:27:57 -0700 Subject: [movitz-cvs] CVS update: public_html/index.html Message-ID: Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv31136 Modified Files: index.html Log Message: *** empty log message *** Date: Wed Aug 18 02:27:57 2004 Author: ffjeld Index: public_html/index.html diff -u public_html/index.html:1.19 public_html/index.html:1.20 --- public_html/index.html:1.19 Wed Jul 7 17:14:35 2004 +++ public_html/index.html Wed Aug 18 02:27:57 2004 @@ -15,6 +15,13 @@

Most recent news

+

August 18, 2004: Movitz finally runs in QEMU, which is a very + nice x86 emulator. It uses some sort of JIT technique, so it's much + faster than Bochs. There was a bug in QEMU's (version 0.6.0) + emulation of the x86 bounds instruction, which didn't agree + with Movitz, and which is now fixed in QEMU's CVS. +

July 8, 2004: The data-structure for vectors has been changed. The vectors length is now represented by a fixnum, increasing the maximum length from #xffff to From ffjeld at common-lisp.net Wed Aug 18 09:50:33 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 18 Aug 2004 02:50:33 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8448 Modified Files: integers.lisp Log Message: Make (* ) observe the register discipline, i.e. by exchanging the usage of ECX and ESI. Date: Wed Aug 18 02:50:33 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.92 movitz/losp/muerte/integers.lisp:1.93 --- movitz/losp/muerte/integers.lisp:1.92 Mon Aug 16 08:26:36 2004 +++ movitz/losp/muerte/integers.lisp Wed Aug 18 02:50:33 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.92 2004/08/16 15:26:36 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.93 2004/08/18 09:50:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -333,6 +333,7 @@ (define-compiler-macro =%2op (n1 n2 &environment env) (cond + #+ignore ((movitz:movitz-constantp n1 env) (let ((n1 (movitz:movitz-eval n1 env))) (etypecase n1 @@ -353,6 +354,7 @@ `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil) (:compile-two-forms (:eax :ebx) ,n1 ,n2) (:call-global-pf fast-compare-two-reals)))))) + #+ignore ((movitz:movitz-constantp n2 env) `(=%2op ,n2 ,n1)) (t `(eql ,n1 ,n2)))) @@ -1137,39 +1139,39 @@ (:store-lexical (:lexical-binding r) :eax :type bignum) (:movl :eax :ebx) ; r into ebx - (:xorl :ecx :ecx) ; counter + (:xorl :esi :esi) ; counter (:xorl :edx :edx) ; initial carry (:std) ; Make EAX, EDX, ESI non-GC-roots. - (:compile-form (:result-mode :esi) x) - (:sarl ,movitz:+movitz-fixnum-shift+ :esi) + (:compile-form (:result-mode :ecx) x) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:jns 'multiply-loop) - (:negl :esi) ; can't overflow + (:negl :ecx) ; can't overflow multiply-loop - (:movl :edx (:ebx (:ecx 1) ; new + (:movl :edx (:ebx (:esi 1) ; new (:offset movitz-bignum bigit0))) (:compile-form (:result-mode :ebx) y) - (:movl (:ebx (:ecx 1) (:offset movitz-bignum bigit0)) + (:movl (:ebx (:esi 1) (:offset movitz-bignum bigit0)) :eax) - (:mull :esi :eax :edx) + (:mull :ecx :eax :edx) (:compile-form (:result-mode :ebx) r) - (:addl :eax (:ebx :ecx (:offset movitz-bignum bigit0))) + (:addl :eax (:ebx :esi (:offset movitz-bignum bigit0))) (:adcl 0 :edx) - (:addl 4 :ecx) - (:cmpw :cx (:ebx (:offset movitz-bignum length))) + (:addl 4 :esi) + (:cmpw :si (:ebx (:offset movitz-bignum length))) (:ja 'multiply-loop) (:testl :edx :edx) (:jz 'no-carry-expansion) - (:movl :edx (:ebx :ecx (:offset movitz-bignum bigit0))) - (:addl 4 :ecx) - (:movw :cx (:ebx (:offset movitz-bignum length))) + (:movl :edx (:ebx :esi (:offset movitz-bignum bigit0))) + (:addl 4 :esi) + (:movw :si (:ebx (:offset movitz-bignum length))) no-carry-expansion + (:leal (:esi ,movitz:+movitz-fixnum-factor+) + :ecx) ; Put bignum length into ECX (:movl (:ebp -4) :esi) (:movl :ebx :eax) (:movl :edi :edx) (:cld) ; EAX, EDX, and ESI are GC roots again. - (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+) - :ecx) (:call-local-pf cons-commit) (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) (:edi (:edi-offset atomically-status)))) From ffjeld at common-lisp.net Wed Aug 18 20:16:28 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 18 Aug 2004 13:16:28 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/eval.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15555 Modified Files: eval.lisp Log Message: Fixed interpreted setq and setf to deal with lexical variables, according to Alessio Stalla's bug-report. Date: Wed Aug 18 13:16:27 2004 Author: ffjeld Index: movitz/losp/muerte/eval.lisp diff -u movitz/losp/muerte/eval.lisp:1.9 movitz/losp/muerte/eval.lisp:1.10 --- movitz/losp/muerte/eval.lisp:1.9 Wed Jun 16 00:37:17 2004 +++ movitz/losp/muerte/eval.lisp Wed Aug 18 13:16:26 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.9 2004/06/16 07:37:17 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.10 2004/08/18 20:16:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -366,28 +366,38 @@ (unless b (error "Go-tag ~S is not visible." tag)) (throw (cdr b) (values tag)))) +(defun eval-set-variable (variable-name value env) + "Perform e.g. (setq ) according to . Return ." + (check-type variable-name symbol "a variable name") + (if (symbol-special-variable-p variable-name) + (set variable-name value) + (let ((binding (env-binding env variable-name))) + (if binding + (setf (cdr binding) value) + ;; We could emit a warning here, or whatever. + (set variable-name value))))) (defun eval-setq (form env) (do* ((p (cdr form) (cddr p)) - (value nil)) - ((null p) value) + (final-value nil)) + ((null p) final-value) (assert (cdr p) (form) "Odd number of arguments to setq: ~W" form) - (setf value - (set (car p) (eval-form (cadr p) env))))) + (setf final-value + (eval-set-variable (car p) (eval-form (cadr p) env) env)))) (defun eval-setf (form env) (do* ((p (cdr form) (cddr p)) - (value nil)) - ((null p) value) + (final-value nil)) + ((null p) final-value) (assert (cdr p) (form) "Odd number of arguments to setf: ~W" form) - (setf value + (setf final-value (let ((place (first p)) (value-form (second p))) (if (symbolp place) - (set place (eval-form value-form env)) - ;; eval subvalues before value-form.. + (eval-set-variable place (eval-form value-form env) env) + ;; eval place's subforms before value-form.. (let ((place-subvalues (eval-arglist (cdr place) env))) (apply (lookup-setf-function (caar p)) (eval-form value-form env) From ffjeld at common-lisp.net Wed Aug 18 22:30:55 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 18 Aug 2004 15:30:55 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv31712 Modified Files: compiler.lisp Log Message: Two things: No more barf on unused local functions (flets or labels), just emit a warning. Also, fix initialization of lended &optionals. Date: Wed Aug 18 15:30:52 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.95 movitz/compiler.lisp:1.96 --- movitz/compiler.lisp:1.95 Mon Aug 16 01:24:56 2004 +++ movitz/compiler.lisp Wed Aug 18 15:30:51 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.95 2004/08/16 08:24:56 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.96 2004/08/18 22:30:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -653,6 +653,8 @@ (cond ((or (null usage) (null (borrowed-bindings sub-funobj))) + (when (null usage) + (warn "null usage for ~S" sub-funobj)) (change-class function-binding 'funobj-binding) (setf (movitz-funobj-extent sub-funobj) :indefinite-extent)) @@ -2555,9 +2557,10 @@ ((:local-function-init :load-lambda) (let* ((binding (second instruction)) (funobj (function-binding-funobj binding))) - (incf (getf constants funobj 0)) - (dolist (binding (borrowed-bindings funobj)) - (process-binding binding)))) + (unless (eq :unused (movitz-funobj-extent funobj)) + (incf (getf constants funobj 0)) + (dolist (binding (borrowed-bindings funobj)) + (process-binding binding))))) ((:load-lexical :lend-lexical :call-lexical) (process-binding (second instruction))) (:load-constant @@ -3621,26 +3624,34 @@ (:local-function-init (destructuring-bind (function-binding) (operands instruction) - #+ignore (warn "local-function-init: init ~S at ~S" - function-binding - (new-binding-location function-binding frame-map)) + #+ignore + (warn "local-function-init: init ~S at ~S" + function-binding + (new-binding-location function-binding frame-map)) (finalize-code - (let* ((sub-funobj (function-binding-funobj function-binding)) - (lend-code (loop for bb in (borrowed-bindings sub-funobj) - append (make-lend-lexical bb :edx nil)))) + (let* ((sub-funobj (function-binding-funobj function-binding))) (cond + ((eq (movitz-funobj-extent sub-funobj) :unused) + (unless (or (movitz-env-get (binding-name function-binding) + 'ignore nil + (binding-env function-binding) nil) + (movitz-env-get (binding-name function-binding) + 'ignorable nil + (binding-env function-binding) nil)) + (warn "Unused local function: ~S" + (binding-name function-binding))) + nil) ((typep function-binding 'funobj-binding) nil) - ((null lend-code) - (warn "null lending") - (append (make-load-constant sub-funobj :eax funobj frame-map) - (make-store-lexical function-binding :eax nil frame-map))) - (t (append (make-load-constant sub-funobj :eax funobj frame-map) + (t (when (null (borrowed-bindings sub-funobj)) + (warn "null lending for ~S" sub-funobj)) + (append (make-load-constant sub-funobj :eax funobj frame-map) `((:movl (:edi ,(global-constant-offset 'copy-funobj)) :esi) (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%1op))) (:movl :eax :edx)) (make-store-lexical function-binding :eax nil frame-map) - lend-code)))) + (loop for bb in (borrowed-bindings sub-funobj) + append (make-lend-lexical bb :edx nil)))))) funobj frame-map))) (:load-lambda (destructuring-bind (function-binding register) @@ -4284,9 +4295,14 @@ (function-argument-argnum binding))) and optional-ok-label = (make-symbol (format nil "optional-~D-ok" (function-argument-argnum binding))) - unless (movitz-env-get optional-var 'ignore nil env nil) + unless (movitz-env-get optional-var 'ignore nil env nil) ; XXX append - `((:init-lexvar ,binding)) + (cond + ((= 0 (function-argument-argnum binding)) + `((:init-lexvar ,binding :init-with-register :eax :init-with-type t))) + ((= 1 (function-argument-argnum binding)) + `((:init-lexvar ,binding :init-with-register :ebx :init-with-type t))) + (t `((:init-lexvar ,binding)))) when supplied-p-binding append `((:init-lexvar ,supplied-p-binding)) append @@ -4297,33 +4313,24 @@ :env env :result-mode :edx) (cond - #+ignore ((and (eq 'compile-self-evaluating producer) - (= 0 (function-argument-argnum binding)) - (not supplied-p-var)) - (append `((:store-lexical ,binding :eax) - (:arg-cmp 1) - (:jge ',optional-ok-label)) - (compiler-call #'compile-form - :form (optional-function-argument-init-form binding) - :funobj funobj - :env env - :result-mode binding) - (list optional-ok-label))) - #+ignore - ((and (eq 'compile-self-evaluating producer) - (= 1 (function-argument-argnum binding)) - (not eax-optional-destructive-p) - (not supplied-p-var)) - (append `((:store-lexical ,binding :ebx) - (:arg-cmp 2) - (:jge ',optional-ok-label)) - (compiler-call #'compile-form - :form (optional-function-argument-init-form binding) - :funobj funobj - :env env - :result-mode binding) - (list optional-ok-label))) + (member (function-argument-argnum binding) '(0 1))) + ;; The binding is already preset with EAX or EBX. + (check-type binding lexical-binding) + (append + (when supplied-p-var + `((:load-constant ,(movitz-read t) :edx) + (:store-lexical ,supplied-p-binding :edx :type (member t)))) + `((:arg-cmp ,(function-argument-argnum binding)) + (:ja ',optional-ok-label)) + (compiler-call #'compile-form + :form (optional-function-argument-init-form binding) + :funobj funobj + :env env + :result-mode binding) + (when supplied-p-var + `((:store-lexical ,supplied-p-binding :edi :type null))) + `(,optional-ok-label))) ((eq 'compile-self-evaluating producer) `(,@(when supplied-p-var `((:store-lexical ,supplied-p-binding :edi :type null))) @@ -4342,7 +4349,8 @@ :eax) (:store-lexical ,binding :eax :type t))) (t (setq need-normalized-ecx-p t) - `((:movl (:ebp (:ecx 4) ,(* -4 (1- (function-argument-argnum binding)))) + `((:movl (:ebp (:ecx 4) + ,(* -4 (1- (function-argument-argnum binding)))) :eax) (:store-lexical ,binding :eax :type t)))))) ,@(when supplied-p-var @@ -4350,49 +4358,48 @@ (:store-lexical ,supplied-p-binding :eax :type (eql ,(image-t-symbol *image*))))) ,not-present-label)) - (t #+ignore (when (= 0 (function-argument-argnum binding)) - (setf eax-optional-destructive-p t)) - `((:arg-cmp ,(function-argument-argnum binding)) - (:jbe ',not-present-label) - ,@(when supplied-p-var - `((:movl (:edi ,(global-constant-offset 't-symbol)) :eax) - (:store-lexical ,supplied-p-binding :eax - :type (eql ,(image-t-symbol *image*))))) - ,@(case (function-argument-argnum binding) - (0 `((:store-lexical ,binding :eax :type t))) - (1 `((:store-lexical ,binding :ebx :type t))) - (t (cond - (last-optional-p - `((:movl (:ebp ,(* 4 (- (1+ (function-argument-argnum binding)) - -1 (function-argument-argnum binding)))) - :eax) - (:store-lexical ,binding :eax :type t))) - (t (setq need-normalized-ecx-p t) - `((:movl (:ebp (:ecx 4) ,(* -4 (1- (function-argument-argnum binding)))) - :eax) - (:store-lexical ,binding :eax :type t)))))) - (:jmp ',optional-ok-label) - ,not-present-label - ,@(when supplied-p-var - `((:store-lexical ,supplied-p-binding :edi :type null))) - ,@(when (and (= 0 (function-argument-argnum binding)) - (not last-optional-p)) - `((:pushl :ebx))) ; protect ebx - ,@(if (optional-function-argument-init-form binding) - (append '((:pushl :ecx)) - (when (= 0 (function-argument-argnum binding)) - `((:pushl :ebx))) - init-code-edx - `((:store-lexical ,binding :edx :type t)) - (when (= 0 (function-argument-argnum binding)) - `((:popl :ebx))) - `((:popl :ecx))) - (progn (error "Unsupported situation.") - #+ignore `((:store-lexical ,binding :edi :type null)))) - ,@(when (and (= 0 (function-argument-argnum binding)) - (not last-optional-p)) - `((:popl :ebx))) ; protect ebx - ,optional-ok-label))))) + (t `((:arg-cmp ,(function-argument-argnum binding)) + (:jbe ',not-present-label) + ,@(when supplied-p-var + `((:movl (:edi ,(global-constant-offset 't-symbol)) :eax) + (:store-lexical ,supplied-p-binding :eax + :type (eql ,(image-t-symbol *image*))))) + ,@(case (function-argument-argnum binding) + (0 `((:store-lexical ,binding :eax :type t))) + (1 `((:store-lexical ,binding :ebx :type t))) + (t (cond + (last-optional-p + `((:movl (:ebp ,(* 4 (- (1+ (function-argument-argnum binding)) + -1 (function-argument-argnum binding)))) + :eax) + (:store-lexical ,binding :eax :type t))) + (t (setq need-normalized-ecx-p t) + `((:movl (:ebp (:ecx 4) + ,(* -4 (1- (function-argument-argnum binding)))) + :eax) + (:store-lexical ,binding :eax :type t)))))) + (:jmp ',optional-ok-label) + ,not-present-label + ,@(when supplied-p-var + `((:store-lexical ,supplied-p-binding :edi :type null))) + ,@(when (and (= 0 (function-argument-argnum binding)) + (not last-optional-p)) + `((:pushl :ebx))) ; protect ebx + ,@(if (optional-function-argument-init-form binding) + (append '((:pushl :ecx)) + (when (= 0 (function-argument-argnum binding)) + `((:pushl :ebx))) + init-code-edx + `((:store-lexical ,binding :edx :type t)) + (when (= 0 (function-argument-argnum binding)) + `((:popl :ebx))) + `((:popl :ecx))) + (progn (error "Unsupported situation.") + #+ignore `((:store-lexical ,binding :edi :type null)))) + ,@(when (and (= 0 (function-argument-argnum binding)) + (not last-optional-p)) + `((:popl :ebx))) ; protect ebx + ,optional-ok-label))))) (when rest-var (let* ((rest-binding (movitz-binding rest-var env)) #+ignore (rest-position (function-argument-argnum rest-binding))) @@ -6265,6 +6272,13 @@ (result-type (multiple-value-call #'encoded-integer-types-add (values-list (binding-store-type term0)) (values-list (binding-store-type term1))))) + (when (binding-lended-p term0) + (warn "Add for lend0: ~S" term0)) + (when (binding-lended-p term1) + (warn "Add for lend0: ~S" term1)) + (when (and (bindingp destination) + (binding-lended-p destination)) + (warn "Add for lend0: ~S" destination)) (let ((loc0 (new-binding-location term0 frame-map :default nil)) (loc1 (new-binding-location term1 frame-map :default nil))) ;;; (warn "add: ~A" instruction) From ffjeld at common-lisp.net Wed Aug 18 22:32:56 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 18 Aug 2004 15:32:56 -0700 Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: 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 From ffjeld at common-lisp.net Wed Aug 18 22:35:46 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 18 Aug 2004 15:35:46 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: 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)))) From ffjeld at common-lisp.net Wed Aug 18 22:36:38 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 18 Aug 2004 15:36:38 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/bignums.lisp Message-ID: 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 ;;;; 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 From ffjeld at common-lisp.net Wed Aug 18 22:38:01 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 18 Aug 2004 15:38:01 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: 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 ;;;; 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. From ffjeld at common-lisp.net Thu Aug 19 00:22:04 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 18 Aug 2004 17:22:04 -0700 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: 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 From ffjeld at common-lisp.net Thu Aug 19 00:28:46 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 18 Aug 2004 17:28:46 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/tmp/ext2fs.lisp Message-ID: 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 From ffjeld at common-lisp.net Thu Aug 19 00:28:51 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 18 Aug 2004 17:28:51 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/tmp/fs.lisp Message-ID: 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 From ffjeld at common-lisp.net Thu Aug 19 00:28:57 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 18 Aug 2004 17:28:57 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/tmp/partitions.lisp Message-ID: 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 From ffjeld at common-lisp.net Mon Aug 23 13:46:20 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 23 Aug 2004 06:46:20 -0700 Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp Message-ID: 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 ;;;; 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) From ffjeld at common-lisp.net Mon Aug 23 13:49:41 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 23 Aug 2004 06:49:41 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp Message-ID: 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 ;;;; 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) , at body) + (when ,var (sti)))))) + ;;; Some macros that aren't implemented, and we want to give compiler errors. From ffjeld at common-lisp.net Mon Aug 23 13:51:58 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 23 Aug 2004 06:51:58 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv32256 Modified Files: primitive-functions.lisp Log Message: When setting up a 'fake' stack-frame in a PF, don't use ESI as the funobj. Not really sure what to /do/ use, yet.. Date: Mon Aug 23 06:51:57 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.39 movitz/losp/muerte/primitive-functions.lisp:1.40 --- movitz/losp/muerte/primitive-functions.lisp:1.39 Sat Aug 7 04:12:09 2004 +++ movitz/losp/muerte/primitive-functions.lisp Mon Aug 23 06:51:57 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.39 2004/08/07 11:12:09 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.40 2004/08/23 13:51:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -122,7 +122,7 @@ (with-inline-assembly (:returns :push) (:pushl :ebp) (:movl :esp :ebp) ; set up a pseudo stack-frame - (:pushl :esi) ; for consistency + (:pushl 4) (:globally (:movl (:edi (:edi-offset unwind-protect-tag)) :edx)) (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) From ffjeld at common-lisp.net Mon Aug 23 13:53:40 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 23 Aug 2004 06:53:40 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/ne2k.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv27586 Modified Files: ne2k.lisp Log Message: Made the ne2000 prober slightly less picky about the state of the dp8390 registers, so that it'll find the QEMU ne2k device. Date: Mon Aug 23 06:53:38 2004 Author: ffjeld Index: movitz/losp/x86-pc/ne2k.lisp diff -u movitz/losp/x86-pc/ne2k.lisp:1.10 movitz/losp/x86-pc/ne2k.lisp:1.11 --- movitz/losp/x86-pc/ne2k.lisp:1.10 Wed Jul 21 17:58:56 2004 +++ movitz/losp/x86-pc/ne2k.lisp Mon Aug 23 06:53:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 17 15:16:00 2002 ;;;; -;;;; $Id: ne2k.lisp,v 1.10 2004/07/22 00:58:56 ffjeld Exp $ +;;;; $Id: ne2k.lisp,v 1.11 2004/08/23 13:53:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -53,8 +53,8 @@ (io-delay 5000) (setf (dp8390 #x1f) tmp)) (cond - ((not (and (= (logand #b00111111 (dp8390 ($page0-read cr))) - ($command stop abort-complete)) + ((not (and #+ignore (= (logand #b00111111 (dp8390 ($page0-read cr))) + ($command stop abort-complete)) (eq 'ne2000 (ne-x000-probe io-base)))) (format t "failed.~%")) (t (let ((device (make-ne2000 io-base))) From ffjeld at common-lisp.net Mon Aug 23 13:58:09 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 23 Aug 2004 06:58:09 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv1376 Modified Files: los0-gc.lisp Log Message: Changed the way stack locations are represented: Rather than merely a 'location' (which is a simple pointer, and so GC-unsafe), we now use two values: a vector and an index. If vector is non-nil, index is a an index into the vector. If vector is nil, index is a location (as before), typically referencing the currently active stack, which won't move (but probably this mode should be deprecated). Date: Mon Aug 23 06:58:07 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.33 movitz/losp/los0-gc.lisp:1.34 --- movitz/losp/los0-gc.lisp:1.33 Tue Jul 27 06:53:33 2004 +++ movitz/losp/los0-gc.lisp Mon Aug 23 06:58:07 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.33 2004/07/27 13:53:33 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.34 2004/08/23 13:58:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -368,7 +368,7 @@ nil x))) (map-heap-words #'zap-oldspace 0 (malloc-end)) - (map-stack-words #'zap-oldspace (current-stack-frame)) + (map-stack-words #'zap-oldspace nil (current-stack-frame)) (initialize-space oldspace) (values)))) @@ -377,92 +377,95 @@ (defun stop-and-copy (&optional evacuator) (setf (fill-pointer *x*) 0) - (let* ((space0 (%run-time-context-slot 'nursery-space)) - (space1 (space-other space0))) - (check-type space0 vector-u32) - (check-type space1 vector-u32) - (assert (eq space0 (space-other space1))) - (multiple-value-bind (newspace oldspace) - (if (< (space-fresh-pointer space0) ; Chose the emptiest space as newspace. - (space-fresh-pointer space1)) - (values space0 space1) - (values space1 space0)) - ;; Ensure newspace is activated. - (setf (%run-time-context-slot 'nursery-space) newspace) - ;; Evacuate-oldspace is to be mapped over every potential pointer. - (let ((evacuator - (or evacuator - (lambda (x location) - "If x is in oldspace, migrate it to newspace." - (declare (ignore location)) - (cond - ((not (object-in-space-p oldspace x)) - x) - (t (let ((forwarded-x (memref (object-location x) 0 0 :lisp))) - (if (object-in-space-p newspace forwarded-x) - (progn - (assert (eq (object-tag forwarded-x) - (object-tag x))) - forwarded-x) - (let ((forward-x (shallow-copy x))) - (when (and (typep x 'muerte::pointer) - *gc-consitency-check*) - (let ((a *x*)) - (vector-push (%object-lispval x) a) - (vector-push (memref (object-location x) 0 0 :unsigned-byte32) a) - (assert (vector-push (%object-lispval forward-x) a)))) - (setf (memref (object-location x) 0 0 :lisp) forward-x) - forward-x))))))))) - (setf *gc-stack* (muerte::copy-control-stack)) - ;; Scavenge roots - (dolist (range muerte::%memory-map-roots%) - (map-heap-words evacuator (car range) (cdr range))) - (map-stack-words evacuator (current-stack-frame)) - ;; Scan newspace, Cheney style. - (loop with newspace-location = (+ 2 (object-location newspace)) - with scan-pointer = 2 - as fresh-pointer = (space-fresh-pointer newspace) - while (< scan-pointer fresh-pointer) - do (map-heap-words evacuator - (+ newspace-location scan-pointer) - (+ newspace-location (space-fresh-pointer newspace))) - (setf scan-pointer fresh-pointer)) - - ;; Consistency check.. - (when *gc-consitency-check* - (let ((a *x*)) - ;; First, restore the state of old-space - (do ((i 0 (+ i 3))) - ((>= i (length a))) - (let ((old (%lispval-object (aref a i))) - (old-class (aref a (+ i 1)))) - (setf (memref (object-location old) 0 0 :unsigned-byte32) old-class))) - ;; Then, check that each migrated object is equalp to its new self. - (do ((i 0 (+ i 3))) - ((>= i (length a))) - (let ((old (%lispval-object (aref a i))) - (new (%lispval-object (aref a (+ i 2))))) - (unless (and (object-in-space-p newspace new) - (object-in-space-p oldspace old) - (objects-equalp old new)) - (let ((*old* old) - (*new* new) - (*old-class* (aref a (+ i 1)))) - (declare (special *old* *new* *old-class*)) - (with-simple-restart (continue "Ignore failed GC consistency check.") - (error "GC consistency check failed: + (multiple-value-bind (newspace oldspace) + (without-interrupts + (let* ((space0 (%run-time-context-slot 'nursery-space)) + (space1 (space-other space0))) + (check-type space0 vector-u32) + (check-type space1 vector-u32) + (assert (eq space0 (space-other space1))) + (multiple-value-bind (newspace oldspace) + (if (< (space-fresh-pointer space0) ; Chose the emptiest space as newspace. + (space-fresh-pointer space1)) + (values space0 space1) + (values space1 space0)) + ;; Ensure newspace is activated. + (setf (%run-time-context-slot 'nursery-space) newspace) + (values newspace oldspace)))) + ;; Evacuate-oldspace is to be mapped over every potential pointer. + (let ((evacuator + (or evacuator + (lambda (x location) + "If x is in oldspace, migrate it to newspace." + (declare (ignore location)) + (cond + ((not (object-in-space-p oldspace x)) + x) + (t (let ((forwarded-x (memref (object-location x) 0 0 :lisp))) + (if (object-in-space-p newspace forwarded-x) + (progn + (assert (eq (object-tag forwarded-x) + (object-tag x))) + forwarded-x) + (let ((forward-x (shallow-copy x))) + (when (and (typep x 'muerte::pointer) + *gc-consitency-check*) + (let ((a *x*)) + (vector-push (%object-lispval x) a) + (vector-push (memref (object-location x) 0 0 :unsigned-byte32) a) + (assert (vector-push (%object-lispval forward-x) a)))) + (setf (memref (object-location x) 0 0 :lisp) forward-x) + forward-x))))))))) + (setf *gc-stack* (muerte::copy-control-stack)) + ;; Scavenge roots + (dolist (range muerte::%memory-map-roots%) + (map-heap-words evacuator (car range) (cdr range))) + (map-stack-words evacuator nil (current-stack-frame)) + ;; Scan newspace, Cheney style. + (loop with newspace-location = (+ 2 (object-location newspace)) + with scan-pointer = 2 + as fresh-pointer = (space-fresh-pointer newspace) + while (< scan-pointer fresh-pointer) + do (map-heap-words evacuator + (+ newspace-location scan-pointer) + (+ newspace-location (space-fresh-pointer newspace))) + (setf scan-pointer fresh-pointer)) + + ;; Consistency check.. + (when *gc-consitency-check* + (let ((a *x*)) + ;; First, restore the state of old-space + (do ((i 0 (+ i 3))) + ((>= i (length a))) + (let ((old (%lispval-object (aref a i))) + (old-class (aref a (+ i 1)))) + (setf (memref (object-location old) 0 0 :unsigned-byte32) old-class))) + ;; Then, check that each migrated object is equalp to its new self. + (do ((i 0 (+ i 3))) + ((>= i (length a))) + (let ((old (%lispval-object (aref a i))) + (new (%lispval-object (aref a (+ i 2))))) + (unless (and (object-in-space-p newspace new) + (object-in-space-p oldspace old) + (objects-equalp old new)) + (let ((*old* old) + (*new* new) + (*old-class* (aref a (+ i 1)))) + (declare (special *old* *new* *old-class*)) + (with-simple-restart (continue "Ignore failed GC consistency check.") + (error "GC consistency check failed: old object: ~Z: ~S new object: ~Z: ~S oldspace: ~Z, newspace: ~Z, i: ~D" - old old new new oldspace newspace i)))))))) + old old new new oldspace newspace i)))))))) - ;; GC completed, oldspace is evacuated. - (unless *gc-quiet* - (let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2)) - (new-size (truncate (- (space-fresh-pointer newspace) 2) 2))) - (format t "Old space: ~/muerte:pprint-clumps/, new space: ~ + ;; GC completed, oldspace is evacuated. + (unless *gc-quiet* + (let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2)) + (new-size (truncate (- (space-fresh-pointer newspace) 2) 2))) + (format t "Old space: ~/muerte:pprint-clumps/, new space: ~ ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%" - old-size new-size (- old-size new-size)))) - (initialize-space oldspace) - (fill oldspace #x13 :start 2)))) + old-size new-size (- old-size new-size)))) + (initialize-space oldspace) + #+ignore (fill oldspace #x13 :start 2))) (values)) From ffjeld at common-lisp.net Mon Aug 23 13:58:20 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 23 Aug 2004 06:58:20 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4258 Modified Files: conditions.lisp Log Message: Changed the way stack locations are represented: Rather than merely a 'location' (which is a simple pointer, and so GC-unsafe), we now use two values: a vector and an index. If vector is non-nil, index is a an index into the vector. If vector is nil, index is a location (as before), typically referencing the currently active stack, which won't move (but probably this mode should be deprecated). Date: Mon Aug 23 06:58:19 2004 Author: ffjeld Index: movitz/losp/muerte/conditions.lisp diff -u movitz/losp/muerte/conditions.lisp:1.11 movitz/losp/muerte/conditions.lisp:1.12 --- movitz/losp/muerte/conditions.lisp:1.11 Fri Jul 23 08:35:45 2004 +++ movitz/losp/muerte/conditions.lisp Mon Aug 23 06:58:19 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.11 2004/07/23 15:35:45 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.12 2004/08/23 13:58:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -285,7 +285,7 @@ (format t "~%Condition for debugger: ~Z" condition) (format t "~%No abort restart is active. Halting CPU.") (halt-cpu)))) - (t (let ((*debugger-invoked-stack-frame* (stack-frame-uplink (current-stack-frame)))) + (t (let ((*debugger-invoked-stack-frame* (stack-frame-uplink nil (current-stack-frame)))) (funcall *debugger-function* condition)))) (format *debug-io* "~&Debugger ~@[on ~S ]returned!~%Trying to abort...~%" condition) (let ((r (find-restart 'abort))) From ffjeld at common-lisp.net Mon Aug 23 13:58:29 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 23 Aug 2004 06:58:29 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6306 Modified Files: inspect.lisp Log Message: Changed the way stack locations are represented: Rather than merely a 'location' (which is a simple pointer, and so GC-unsafe), we now use two values: a vector and an index. If vector is non-nil, index is a an index into the vector. If vector is nil, index is a location (as before), typically referencing the currently active stack, which won't move (but probably this mode should be deprecated). Date: Mon Aug 23 06:58:27 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.34 movitz/losp/muerte/inspect.lisp:1.35 --- movitz/losp/muerte/inspect.lisp:1.34 Thu Jul 29 05:51:40 2004 +++ movitz/losp/muerte/inspect.lisp Mon Aug 23 06:58:25 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.34 2004/07/29 12:51:40 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.35 2004/08/23 13:58:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -38,33 +38,8 @@ (declare (without-check-stack-limit)) ; we do it explicitly.. (check-stack-limit)) -(defun stack-top () - (declare (without-check-stack-limit)) - (load-global-constant stack-top :thread-local t)) - -(defun stack-bottom () - (declare (without-check-stack-limit)) - (load-global-constant stack-bottom :thread-local t)) - -(defun (setf stack-top) (value) - (declare (without-check-stack-limit)) - (check-type value fixnum) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) value) - ((:fs-override) :movl :eax (:edi #.(movitz::global-constant-offset 'stack-top))))) - - -(defun (setf stack-bottom) (value) - (declare (without-check-stack-limit)) - (check-type value fixnum) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) value) - ((:fs-override) :movl :eax (:edi #.(movitz::global-constant-offset 'stack-bottom))))) - - -(defun stack-frame-uplink (stack-frame) - (values (truncate (stack-ref (* 4 stack-frame) 0 0 :unsigned-byte32) - 4))) +(defun stack-frame-uplink (stack frame) + (stack-frame-ref stack frame 0)) (define-compiler-macro current-stack-frame () `(with-inline-assembly (:returns :eax) @@ -72,42 +47,41 @@ :eax))) (defun current-stack-frame () - (stack-frame-uplink (current-stack-frame))) + (stack-frame-uplink nil (current-stack-frame))) -(defun stack-frame-funobj (stack-frame &optional accept-non-funobjs) +(defun stack-frame-funobj (stack frame) + (stack-frame-ref stack frame -1) + #+ignore (when stack-frame - (let ((x (stack-frame-ref stack-frame -1))) + (let ((x (stack-frame-ref stack-frame -1 stack))) (and (or accept-non-funobjs (typep x 'function)) x)))) -(defun stack-frame-call-site (stack-frame) +(defun stack-frame-call-site (stack frame) "Return the code-vector and offset into this vector that is immediately after the point that called this stack-frame." - (let ((funobj (stack-frame-funobj (stack-frame-uplink stack-frame)))) - (when funobj - (let* ((code-vector (funobj-code-vector funobj)) - (x (stack-ref (* 4 stack-frame) 0 1 :unsigned-byte32)) - (delta (- x 8 (* #.movitz::+movitz-fixnum-factor+ (object-location code-vector))))) - (when (below delta (length code-vector)) - (values delta code-vector funobj)))))) - -(defun stack-frame-ref (stack-frame index) - (if (= 0 index) - (stack-frame-uplink stack-frame) - (stack-ref (* 4 stack-frame) 0 index :lisp))) - -(defun stack-ref-p (pointer) - (let ((top (load-global-constant-u32 stack-top)) - (bottom (with-inline-assembly (:returns :eax) - (:movl :esp :eax) - (:shll #.movitz:+movitz-fixnum-shift+ :eax)))) - (<= bottom pointer top))) - -(defun stack-ref (pointer offset index type) - #+ignore (assert (stack-ref-p pointer) (pointer) - "Stack pointer not in range: #x~X" pointer) - (memref-int pointer offset index type)) + (let ((uplink (stack-frame-uplink stack frame))) + (when (and uplink (not (= 0 uplink))) + (let ((funobj (stack-frame-funobj stack uplink))) + (when (typep funobj 'function) + (let* ((code-vector (funobj-code-vector funobj)) + (eip (stack-frame-ref stack frame 1 :unsigned-byte32)) + (delta (- eip 8 (* #.movitz::+movitz-fixnum-factor+ (object-location code-vector))))) + (when (below delta (length code-vector)) + (values delta code-vector funobj)))))))) + +(defun stack-frame-ref (stack frame index &optional (type ':lisp)) + "If stack is provided, stack-frame is an index into that stack vector. +Otherwise, stack-frame is an absolute location." + (cond + ((not (null stack)) + (check-type stack (simple-array (unsigned-byte 32) 1)) + (let ((pos (+ frame index))) + (assert (< -1 pos (length stack)) + () "Index ~S, pos ~S, len ~S" index pos (length stack)) + (memref stack 2 pos type))) + (t (memref frame 0 index type)))) (defun current-dynamic-context () (with-inline-assembly (:returns :untagged-fixnum-ecx) @@ -340,7 +314,7 @@ (* 2 (truncate (+ (structure-object-length object) 1) 2)))))))) -(defun copy-control-stack (&key (absolutep) +(defun copy-control-stack (&key (relative-uplinks t) (stack (%run-time-context-slot 'stack-vector)) (frame (current-stack-frame))) (assert (location-in-object-p stack frame)) @@ -359,9 +333,13 @@ (assert (< -1 uplink-index (length copy)) () "Uplink-index outside copy: ~S, i: ~S" uplink-index i) (setf (svref%unsafe copy i) - (if absolutep + (if relative-uplinks uplink-index (let ((x (+ uplink-index copy-start-location))) - (assert (location-in-object-p copy x)) - (setf (svref%unsafe copy i) x)))) + (assert (= copy-start-location (+ 2 (object-location copy))) () + "Destination stack re-located!") + (assert (location-in-object-p copy x) () + "Bad uplink ~S computed from index ~S and copy ~Z, csl: ~S" + x uplink-index copy copy-start-location) + x))) (setf i uplink-index)))))))) From ffjeld at common-lisp.net Mon Aug 23 13:58:36 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 23 Aug 2004 06:58:36 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9367 Modified Files: scavenge.lisp Log Message: Changed the way stack locations are represented: Rather than merely a 'location' (which is a simple pointer, and so GC-unsafe), we now use two values: a vector and an index. If vector is non-nil, index is a an index into the vector. If vector is nil, index is a location (as before), typically referencing the currently active stack, which won't move (but probably this mode should be deprecated). Date: Mon Aug 23 06:58:35 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.26 movitz/losp/muerte/scavenge.lisp:1.27 --- movitz/losp/muerte/scavenge.lisp:1.26 Thu Aug 12 10:11:55 2004 +++ movitz/losp/muerte/scavenge.lisp Mon Aug 23 06:58:34 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.26 2004/08/12 17:11:55 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.27 2004/08/23 13:58:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -35,42 +35,34 @@ start-location and end-location." (macrolet ((scavenge-typep (x primary) (let ((code (movitz:tag primary))) - `(with-inline-assembly (:returns :boolean-zf=1) - (:compile-form (:result-mode :eax) ,x) - (:cmpb ,code :al)))) + `(= ,code (ldb (byte 8 0) ,x)))) (scavenge-wide-typep (x primary secondary) (let ((code (dpb secondary (byte 8 8) (movitz:tag primary)))) - `(with-inline-assembly (:returns :boolean-zf=1) - (:compile-form (:result-mode :eax) ,x) - (:cmpw ,code :ax)))) - (word-bigits (x) - "If x is a bignum header word, return the number of bigits." - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) ,x) - (:shrl 16 :eax) - (:testb ,movitz:+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program () (:int 63)))))) + `(= ,code ,x)))) (do ((verbose *map-heap-words-verbose*) (*scan-last* nil) ; Last scanned object, for debugging. (scan start-location (1+ scan))) ((>= scan end-location)) (declare (special *scan-last*)) (let ((*scan* scan) - (x (memref scan 0 0 :lisp))) + (x (memref scan 0 0 :unsigned-byte16))) (declare (special *scan*)) (when verbose - (format *terminal-io* "~&MHW scanning at ~S: ~Z" scan x)) + (format *terminal-io* " [at ~S: ~S]" scan x)) (cond - ((typep x '(or null fixnum character))) + ((let ((tag (ldb (byte 3 0) x))) + (or (= tag #.(movitz:tag :null)) + (= tag #.(movitz:tag :fixnum)) + (scavenge-typep x :character)))) ((scavenge-typep x :illegal) - (error "Illegal word ~Z at ~S." x scan)) + (error "Illegal word ~S at ~S." x scan)) ((scavenge-typep x :bignum) (assert (evenp scan) () - "Scanned ~Z at odd location #x~X." x scan) + "Scanned ~S at odd location #x~X." x scan) ;; Just skip the bigits - (let* ((bigits (word-bigits x)) + (let* ((bigits (memref scan 0 1 :unsigned-byte14)) (delta (logior bigits 1))) (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (incf scan delta))) @@ -128,27 +120,28 @@ (error "Scanned unknown basic-vector #x~Z at address #x~X." x scan)) ((scavenge-typep x :old-vector) (error "Scanned old-vector ~Z at address #x~X." x scan)) - ((eq x (%lispval-object 3)) + ((eq x 3) (incf scan) (let ((delta (memref scan 0 0 :lisp))) (check-type delta positive-fixnum) ;; (warn "at ~S skipping ~S to ~S." scan delta (+ scan delta)) (incf scan delta))) - ((typep x 'pointer) - (let ((new (funcall function x scan))) + (t ;; (typep x 'pointer) + (let* ((old (memref scan 0 0 :lisp)) + (new (funcall function old scan))) (when verbose - (format *terminal-io* " [~Z => ~Z]" x new)) - (unless (eq new x) + (format *terminal-io* " [~Z => ~Z]" old new)) + (unless (eq old new) (setf (memref scan 0 0 :lisp) new)))))))) (values)) -(defun map-stack-words (function start-stack-frame) +(defun map-stack-words (function stack start-frame) "Map function over the potential pointer words of a stack, starting at the start-stack-frame location." - (loop for nether-frame = start-stack-frame then frame - and frame = (stack-frame-uplink start-stack-frame) then (stack-frame-uplink frame) + (loop for nether-frame = start-frame then frame + and frame = (stack-frame-uplink stack start-frame) then (stack-frame-uplink stack frame) while (plusp frame) - do (let ((funobj (funcall function (stack-frame-funobj frame t) nil))) + do (let ((funobj (funcall function (stack-frame-funobj stack frame) nil))) (typecase funobj (function (assert (= 0 (funobj-frame-num-unboxed funobj))) @@ -160,103 +153,108 @@ (cond ((logbitp 10 (dit-frame-ref :eflags :unsigned-byte32 0 dit-frame)) ;; DF flag was 1, so EAX and EDX are not GC roots. + #+ignore (warn "Interrupt in uncommon mode at ~S" (dit-frame-ref :eip :unsigned-byte32 0 dit-frame)) (map-heap-words function ; Assume nothing in the dit-frame above the location .. (+ nether-frame 2) ; ..of EBX holds pointers. (+ frame (dit-frame-index :ebx)))) - (t (warn "Interrupt in COMMON mode!") + (t #+ignore + (warn "Interrupt in COMMON mode!") (map-heap-words function ; Assume nothing in the dit-frame above the location .. (+ nether-frame 2) ; ..of ECX holds pointers. (+ frame (dit-frame-index :ecx))))) ;; 2. Pop to (dit-)frame's CASF (setf nether-frame frame frame (dit-frame-casf frame)) - (let ((casf-funobj (funcall function (stack-frame-funobj frame t) nil)) + (let ((casf-funobj (funcall function (stack-frame-funobj stack frame) nil)) (interrupted-esp (dit-frame-esp dit-frame))) - (assert (typep casf-funobj 'function) () - "Interrupted CASF frame was not a normal function: ~S" - casf-funobj) - (let ((casf-code-vector (funobj-code-vector casf-funobj))) - ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii. - (cond - ((location-in-object-p casf-code-vector - (dit-frame-ref :eip :location 0 dit-frame)) - ;; Situation i. Nothing special on stack, scavenge frame normally. - (map-heap-words function interrupted-esp frame)) - ((eq casf-frame (memref interrupted-esp 0 0 :location)) - ;; Situation ii. esp(0)=CASF, esp(1)=code-vector - (assert (location-in-object-p casf-code-vector - (memref interrupted-esp 0 1 :location)) - () "Stack discipline situation ii. invariant broken. CASF=#x~X" - casf-frame) - (map-heap-words function (+ interrupted-esp 2) frame)) - (t ;; Situation iii. esp(0)=code-vector. - (assert (location-in-object-p casf-code-vector - (memref interrupted-esp 0 0 :location)) - () "Stack discipline situation iii. invariant broken. CASF=#x~X" - casf-frame) - (map-heap-words function (+ interrupted-esp 1) frame))))))) + (cond + ((eq 0 casf-funobj) + (warn "Interrupt (presumably) in interrupt trampoline.")) + (t (assert (typep casf-funobj 'function) () + "Interrupted CASF frame was not a normal function: ~S" + casf-funobj) + (let ((casf-code-vector (funobj-code-vector casf-funobj))) + ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii. + (cond + ((location-in-object-p casf-code-vector + (dit-frame-ref :eip :location 0 dit-frame)) + ;; Situation i. Nothing special on stack, scavenge frame normally. + (map-heap-words function interrupted-esp frame)) + ((eq casf-frame (memref interrupted-esp 0 0 :location)) + ;; Situation ii. esp(0)=CASF, esp(1)=code-vector + (assert (location-in-object-p casf-code-vector + (memref interrupted-esp 0 1 :location)) + () "Stack discipline situation ii. invariant broken. CASF=#x~X" + casf-frame) + (map-heap-words function (+ interrupted-esp 2) frame)) + (t ;; Situation iii. esp(0)=code-vector. + (assert (location-in-object-p casf-code-vector + (memref interrupted-esp 0 0 :location)) + () "Stack discipline situation iii. invariant broken. CASF=#x~X" + casf-frame) + (map-heap-words function (+ interrupted-esp 1) frame))))))))) (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj))))) (values)) -(defparameter *primitive-funcall-patterns* - '((:or - (#xff #x57 (:function-offset :signed8)) ; - (#xff #x97 (:function-offset :signed32))))) ; - -(defun stack-frame-primitive-funcall (funobj stack-location eip-location) - "Is stack-frame in a primitive-function? -If so, return the primitive-function's code-vector." - (declare (ignore eip-location)) - ;; XXXX Really we should make comparisons against :call-local-pf - ;; such that we find the active set of local-pf's from the stack-location! - (let ((return-address (memref stack-location 0 0 :unsigned-byte32)) - (code-vector (funobj-code-vector funobj))) - (multiple-value-bind (return-location return-delta) - (truncate return-address #.movitz:+movitz-fixnum-factor+) - (if (not (location-in-object-p code-vector return-location)) - nil ; A PF must have return-address on top of stack. - (dotimes (offset 5 (warn "mismatch in ~S at ~D from #x~X in ~Z." - funobj - (+ (* (- return-location - (object-location code-vector)) - #.movitz:+movitz-fixnum-factor+) - return-delta - -3 -8) - return-address code-vector)) - (multiple-value-bind (success-p type code ip) - (match-code-pattern *primitive-funcall-patterns* - code-vector (+ (* (- return-location - (object-location code-vector)) - #.movitz:+movitz-fixnum-factor+) - return-delta - -3 -8 (- offset)) - :function-offset) - (when success-p - (return - (let* ((offset (case type - (:signed8 - (if (not (logbitp 7 code)) code (- code 256))) - (:signed32 - ;; We must read the unsigned-byte32 that starts at ip - (let ((x (logior (aref code-vector (- ip 1)) - (* (aref code-vector (+ 0 ip)) #x100) - (* (aref code-vector (+ 1 ip)) #x10000) - (* (aref code-vector (+ 2 ip)) #x1000000)))) - (if (not (logbitp 7 (aref code-vector (+ ip 2)))) - x - (break "Negative 32-bit offset.")))) - (t (break "Match fail: vec: ~Z, ip: ~D" - code-vector (+ (* (- return-location - (object-location code-vector)) - #.movitz:+movitz-fixnum-factor+) - return-delta - -3 -8))))) - (primitive-function (%word-offset (%run-time-context-ref offset) -2))) - (if (not (typep primitive-function 'code-vector)) - nil - primitive-function)))))))))) +;;;(defparameter *primitive-funcall-patterns* +;;; '((:or +;;; (#xff #x57 (:function-offset :signed8)) ; +;;; (#xff #x97 (:function-offset :signed32))))) ; +;;; +;;;(defun stack-frame-primitive-funcall (funobj stack-location eip-location) +;;; "Is stack-frame in a primitive-function? +;;;If so, return the primitive-function's code-vector." +;;; (declare (ignore eip-location)) +;;; ;; XXXX Really we should make comparisons against :call-local-pf +;;; ;; such that we find the active set of local-pf's from the stack-location! +;;; (let ((return-address (memref stack-location 0 0 :unsigned-byte32)) +;;; (code-vector (funobj-code-vector funobj))) +;;; (multiple-value-bind (return-location return-delta) +;;; (truncate return-address #.movitz:+movitz-fixnum-factor+) +;;; (if (not (location-in-object-p code-vector return-location)) +;;; nil ; A PF must have return-address on top of stack. +;;; (dotimes (offset 5 (warn "mismatch in ~S at ~D from #x~X in ~Z." +;;; funobj +;;; (+ (* (- return-location +;;; (object-location code-vector)) +;;; #.movitz:+movitz-fixnum-factor+) +;;; return-delta +;;; -3 -8) +;;; return-address code-vector)) +;;; (multiple-value-bind (success-p type code ip) +;;; (match-code-pattern *primitive-funcall-patterns* +;;; code-vector (+ (* (- return-location +;;; (object-location code-vector)) +;;; #.movitz:+movitz-fixnum-factor+) +;;; return-delta +;;; -3 -8 (- offset)) +;;; :function-offset) +;;; (when success-p +;;; (return +;;; (let* ((offset (case type +;;; (:signed8 +;;; (if (not (logbitp 7 code)) code (- code 256))) +;;; (:signed32 +;;; ;; We must read the unsigned-byte32 that starts at ip +;;; (let ((x (logior (aref code-vector (- ip 1)) +;;; (* (aref code-vector (+ 0 ip)) #x100) +;;; (* (aref code-vector (+ 1 ip)) #x10000) +;;; (* (aref code-vector (+ 2 ip)) #x1000000)))) +;;; (if (not (logbitp 7 (aref code-vector (+ ip 2)))) +;;; x +;;; (break "Negative 32-bit offset.")))) +;;; (t (break "Match fail: vec: ~Z, ip: ~D" +;;; code-vector (+ (* (- return-location +;;; (object-location code-vector)) +;;; #.movitz:+movitz-fixnum-factor+) +;;; return-delta +;;; -3 -8))))) +;;; (primitive-function (%word-offset (%run-time-context-ref offset) -2))) +;;; (if (not (typep primitive-function 'code-vector)) +;;; nil +;;; primitive-function)))))))))) ;;; (check-type primitive-function code-vector) ;;; (if (not (location-in-object-p primitive-function eip-location)) ;;; nil From ffjeld at common-lisp.net Mon Aug 23 13:58:42 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 23 Aug 2004 06:58:42 -0700 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv11425 Modified Files: debugger.lisp Log Message: Changed the way stack locations are represented: Rather than merely a 'location' (which is a simple pointer, and so GC-unsafe), we now use two values: a vector and an index. If vector is non-nil, index is a an index into the vector. If vector is nil, index is a location (as before), typically referencing the currently active stack, which won't move (but probably this mode should be deprecated). Date: Mon Aug 23 06:58:41 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.21 movitz/losp/x86-pc/debugger.lisp:1.22 --- movitz/losp/x86-pc/debugger.lisp:1.21 Thu Aug 12 10:45:39 2004 +++ movitz/losp/x86-pc/debugger.lisp Mon Aug 23 06:58:41 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.21 2004/08/12 17:45:39 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.22 2004/08/23 13:58:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -121,18 +121,19 @@ (:ecx . (#xff #x56 #.(cl:ldb (cl:byte 8 0) (bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector)))))) -(defun stack-frame-numargs (stack-frame) +(defun stack-frame-numargs (stack frame) "Try to determine how many arguments was presented to the stack-frame." - (if (eq (stack-frame-funobj stack-frame) + (if (eq (stack-frame-funobj stack frame) (load-global-constant complicated-class-of)) 1 - (multiple-value-bind (call-site code) - (stack-frame-call-site stack-frame) + (multiple-value-bind (call-site code funobj) + (stack-frame-call-site stack frame) (when (and call-site code) (dolist (map +call-site-numargs-maps+ - (warn "no match at ~D for ~S." + (warn "no match at ~D for ~S frame ~S [~S]." call-site - (stack-frame-funobj (stack-frame-uplink stack-frame)))) + (stack-frame-funobj stack (stack-frame-uplink stack frame)) + frame funobj)) (when (not (mismatch code (cdr map) :start1 (- call-site (length (cdr map))) :end1 call-site)) @@ -262,17 +263,17 @@ #xff #x56 (:code-vector)))) ; # )) -(defun call-site-find (stack-frame register) +(defun call-site-find (stack frame register) "Based on call-site's code, figure out where eax and ebx might be located in the caller's stack-frame or funobj-constants." (macrolet ((success (result) `(return-from call-site-find (values ,result t)))) (multiple-value-bind (call-site-ip code-vector funobj) - (stack-frame-call-site stack-frame) + (stack-frame-call-site stack frame) (when (eq funobj #'apply) - (let ((apply-frame (stack-frame-uplink stack-frame))) - (when (eq 2 (stack-frame-numargs apply-frame)) - (let ((applied (call-site-find apply-frame :ebx))) + (let ((apply-frame (stack-frame-uplink stack frame))) + (when (eq 2 (stack-frame-numargs stack apply-frame)) + (let ((applied (call-site-find stack apply-frame :ebx))) ;; (warn "reg: ~S, applied: ~S" register applied) (case register (:eax (success (first applied))) @@ -287,7 +288,8 @@ (:constant (success result-position)) (:ebp - (success (stack-frame-ref (stack-frame-uplink stack-frame) + (success (stack-frame-ref stack + (stack-frame-uplink stack frame) (signed8-index result-position)))) (:esi (when funobj @@ -297,7 +299,7 @@ #.(bt:slot-offset 'movitz::movitz-funobj 'movitz::constant0))))))) (:esp - (success (stack-frame-ref stack-frame + (success (stack-frame-ref stack frame (+ 2 (signed8-index result-position)))))))))))))) (defparameter *stack-frame-setup-patterns* @@ -357,17 +359,17 @@ (when (match-code-pattern (car pattern-map) code-vector setup-start) (return pattern-map)))))) -(defun print-stack-frame-arglist (stack-frame stack-frame-map - &key (numargs (stack-frame-numargs stack-frame)) +(defun print-stack-frame-arglist (stack frame stack-frame-map + &key (numargs (stack-frame-numargs stack frame)) (edx-p nil)) - (flet ((stack-frame-register-value (register stack-frame stack-map-pos) + (flet ((stack-frame-register-value (stack frame register stack-map-pos) (multiple-value-bind (val success-p) - (call-site-find stack-frame register) + (call-site-find stack frame register) (cond (success-p (values val t)) (stack-map-pos - (values (stack-frame-ref stack-frame stack-map-pos) + (values (stack-frame-ref stack frame stack-map-pos) t)) (t (values nil nil))))) (debug-write (x) @@ -389,7 +391,7 @@ (write-string " ...") (prog () ;; (numargs (min numargs *backtrace-max-args*))) (multiple-value-bind (edx foundp) - (stack-frame-register-value :edx stack-frame (pop stack-frame-map)) + (stack-frame-register-value stack frame :edx (pop stack-frame-map)) (when edx-p (write-string " {edx: ") (if foundp @@ -400,9 +402,9 @@ (return)) (write-char #\space) (if (first stack-frame-map) - (debug-write (stack-frame-ref stack-frame (first stack-frame-map))) + (debug-write (stack-frame-ref stack frame (first stack-frame-map))) (multiple-value-bind (eax eax-p) - (call-site-find stack-frame :eax) + (call-site-find stack frame :eax) (if eax-p (debug-write eax) (write-string "{eax unknown}")))) @@ -410,9 +412,9 @@ (return)) (write-char #\space) (if (second stack-frame-map) - (debug-write (stack-frame-ref stack-frame (second stack-frame-map))) + (debug-write (stack-frame-ref stack frame (second stack-frame-map))) (multiple-value-bind (ebx ebx-p) - (call-site-find stack-frame :ebx) + (call-site-find stack frame :ebx) (if ebx-p (debug-write ebx) (write-string "{ebx unknown}")))) @@ -422,7 +424,7 @@ (write-string " ...") (return)) (write-char #\space) - (debug-write (stack-frame-ref stack-frame i)))))) + (debug-write (stack-frame-ref stack frame i)))))) (values)) (defun safe-print-stack-frame-arglist (&rest args) @@ -432,11 +434,17 @@ (declare (ignore conditon)) (write-string "#")))) -(defun backtrace (&key stack - ((:frame initial-stack-frame) - (or (and stack (svref%unsafe stack 0)) - *debugger-invoked-stack-frame* - (current-stack-frame))) +(defun location-index (vector location) + (assert (location-in-object-p vector location)) + (- location (object-location vector) 2)) + +(defun backtrace (&key (stack nil) + ((:frame initial-stack-frame-index) + (if stack + (stack-frame-ref stack 0 0) + (or *debugger-invoked-stack-frame* + (current-stack-frame)))) + ;; (relative-uplinks (not (eq stack (%run-time-context-slot 'stack-vector)))) ((:spartan *backtrace-be-spartan-p*)) ((:fresh-lines *backtrace-do-fresh-lines*) *backtrace-do-fresh-lines*) (conflate *backtrace-do-conflate*) @@ -448,13 +456,14 @@ (*print-length* *backtrace-print-length*) (*print-level* *backtrace-print-level*)) (loop with conflate-count = 0 with count = 0 - for stack-frame = initial-stack-frame - then (let ((uplink (stack-frame-uplink stack-frame))) - (assert (> uplink stack-frame) () - "Backtracing uplink ~S from frame ~S." uplink stack-frame) + for frame = initial-stack-frame-index + then (let ((uplink (stack-frame-uplink stack frame))) + (assert (> uplink frame) () + "Backtracing uplink ~S from frame index ~S." uplink frame) uplink) - as funobj = (stack-frame-funobj stack-frame t) - do (flet ((print-leadin (stack-frame count conflate-count) + ;; as xxx = (warn "frame: ~S" frame) + as funobj = (stack-frame-funobj stack frame) + do (flet ((print-leadin (stack frame count conflate-count) (when *backtrace-do-fresh-lines* (fresh-line)) (cond @@ -466,13 +475,13 @@ (write-char #\space)) (t (format t "~& |= "))) (when print-returns - (format t "{< ~D}" (stack-frame-call-site stack-frame))) + (format t "{< ~D}" (stack-frame-call-site stack frame))) (when *backtrace-print-frames* - (format t "#x~X " stack-frame)))) + (format t "#x~X " frame)))) (typecase funobj - (integer - (let* ((interrupt-frame stack-frame) - (funobj (dit-frame-ref :esi :lisp 0 interrupt-frame))) + ((eql 0) + (let* ((dit-frame (if (null stack) frame (+ frame 2 (object-location stack)))) + (funobj (dit-frame-ref :esi :lisp 0 dit-frame))) (if (and conflate-interrupts conflate ;; When the interrupted function has a stack-frame, conflate it. (typep funobj 'function) @@ -480,55 +489,55 @@ (incf conflate-count) (progn (incf count) - (print-leadin stack-frame count conflate-count) + (print-leadin stack frame count conflate-count) (setf conflate-count 0) (let ((exception (dit-frame-ref :exception-vector :unsigned-byte32 - 0 interrupt-frame)) + 0 dit-frame)) (eip (dit-frame-ref :eip :unsigned-byte32 - 0 interrupt-frame))) + 0 dit-frame))) (typecase funobj (function (let ((delta (code-vector-offset (funobj-code-vector funobj) eip))) (if delta (format t "{Exception ~D in ~W at PC offset ~D." exception (funobj-name funobj) delta) - (format t "{Exception ~D in ~W at EIP=#x~X. [#x~X]}" - exception (funobj-name funobj) eip interrupt-frame)))) - (t (format t "{Exception ~D with ESI=#x~Z and EIP=#x~X. [#x~X]}" - exception funobj eip interrupt-frame)))))))) + (format t "{Exception ~D in ~W at EIP=#x~X.}" + exception (funobj-name funobj) eip)))) + (t (format t "{Exception ~D with ESI=~Z and EIP=#x~X.}" + exception funobj eip)))))))) (function (let ((name (funobj-name funobj))) (cond ((and conflate (member name *backtrace-conflate-names* :test #'equal)) (incf conflate-count)) (t (incf count) - (when (and *backtrace-stack-frame-barrier* - (<= *backtrace-stack-frame-barrier* stack-frame)) - (write-string " --|") - (return)) + #+ignore (when (and *backtrace-stack-frame-barrier* + (<= *backtrace-stack-frame-barrier* stack-frame)) + (write-string " --|") + (return)) (unless (or (not (integerp length)) (< count length)) (write-string " ...") (return)) - (print-leadin stack-frame count conflate-count) + (print-leadin stack frame count conflate-count) (setf conflate-count 0) (write-char #\() - (let* ((numargs (stack-frame-numargs stack-frame)) + (let* ((numargs (stack-frame-numargs stack frame)) (map (and funobj (funobj-stack-frame-map funobj numargs)))) (cond ((and (car map) (eq name 'unbound-function)) - (let ((real-name (stack-frame-ref stack-frame (car map)))) + (let ((real-name (stack-frame-ref stack frame (car map)))) (format t "{unbound ~S}" real-name))) ((and (car map) (member name +backtrace-gf-discriminatior-functions+)) - (let ((gf (stack-frame-ref stack-frame (car map)))) + (let ((gf (stack-frame-ref stack frame (car map)))) (cond ((typep gf 'muerte::standard-gf-instance) (format t "{gf ~S}" (funobj-name gf))) (t (write-string "[not a gf??]"))) - (safe-print-stack-frame-arglist stack-frame map :numargs numargs))) + (safe-print-stack-frame-arglist stack frame map :numargs numargs))) (t (write name) - (safe-print-stack-frame-arglist stack-frame map + (safe-print-stack-frame-arglist stack frame map :numargs numargs :edx-p (eq 'muerte::&edx (car (funobj-lambda-list funobj))))))) From ffjeld at common-lisp.net Mon Aug 30 14:59:23 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 30 Aug 2004 16:59:23 +0200 Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5363 Modified Files: procfs-image.lisp Log Message: Changed format of dit-frames, reflect this in the procfs debugger too. Date: Mon Aug 30 16:59:23 2004 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.17 movitz/procfs-image.lisp:1.18 --- movitz/procfs-image.lisp:1.17 Mon Aug 23 15:46:18 2004 +++ movitz/procfs-image.lisp Mon Aug 30 16:59:23 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.17 2004/08/23 13:46:18 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.18 2004/08/30 14:59:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -167,8 +167,7 @@ (defun interrupt-frame-index (name) (- 5 (position name - '(nil :eflags :eip :error-code :exception :ebp nil - :ecx :eax :edx :ebx :esi :edi)))) + (symbol-value 'muerte::+dit-frame-map+)))) (defun debug-get-object (word spartan) (if spartan @@ -202,7 +201,8 @@ (edi (get-word (+ (* 4 (interrupt-frame-index :edi)) stack-frame))) (eip (get-word (+ (* 4 (interrupt-frame-index :eip)) stack-frame))) (esi (get-word (+ (* 4 (interrupt-frame-index :esi)) stack-frame))) - (exception (get-word (+ (* 4 (interrupt-frame-index :exception)) stack-frame)))) + (exception (get-word (+ (* 4 (interrupt-frame-index :exception-vector)) + stack-frame)))) (format t "#x~X {EAX: #x~X, ECX: #x~X, EDX: #x~X, EDI: #x~X, ESI: #x~X, EIP: #x~X, exception ~D}" stack-frame eax ecx edx edi esi eip exception))) From ffjeld at common-lisp.net Mon Aug 30 15:16:59 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 30 Aug 2004 17:16:59 +0200 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10728 Modified Files: inspect.lisp Log Message: Fixed keyword typo. Date: Mon Aug 30 17:16:59 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.35 movitz/losp/muerte/inspect.lisp:1.36 --- movitz/losp/muerte/inspect.lisp:1.35 Mon Aug 23 15:58:25 2004 +++ movitz/losp/muerte/inspect.lisp Mon Aug 30 17:16:59 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.35 2004/08/23 13:58:25 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.36 2004/08/30 15:16:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -84,14 +84,14 @@ (t (memref frame 0 index type)))) (defun current-dynamic-context () - (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)))) + (with-inline-assembly (:returns :eax) + (:locally (:movl (:edi (:edi-offset dynamic-env)) :eax)))) (defun dynamic-context-uplink (dynamic-context) - (stack-ref dynamic-context 12 0 :unsigned-byte32)) + (stack-frame-ref nil dynamic-context 3 :lisp)) (defun dynamic-context-tag (dynamic-context) - (stack-ref dynamic-context 4 0 :lisp)) + (stack-frame-ref nil dynamic-context 1 :lisp)) (defmacro with-each-dynamic-context ((&optional start-context result) &rest clauses) "Only use this if you know what you're doing. See run-time.lisp." @@ -103,15 +103,15 @@ (basic-restart-clause (find :basic-restart clauses :key #'caar))) `(do ((,context ,(if start-context start-context '(current-dynamic-context)) (dynamic-context-uplink ,context))) - ((not (stack-ref-p ,context)) ,result) + ((not (plusp ,context)) ,result) (let ((,tag (dynamic-context-tag ,context))) (cond ,@(when bind-clause `(((eq ,tag (load-global-constant unbound-value)) (multiple-value-bind ,(cdar bind-clause) (values ,context - (stack-ref ,context 0 0 :lisp) - (stack-ref ,context 8 0 :lisp)) + (stack-frame-ref nil ,context 0 :lisp) + (stack-frame-ref nil ,context 2 :lisp)) ,@(rest bind-clause))))) ,@(when up-clause `(((eq ,tag (load-global-constant unwind-protect-tag)) @@ -120,14 +120,14 @@ ,@(rest up-clause))))) ,@(when basic-restart-clause `(((eq ,tag (load-global-constant restart-tag)) - (macrolet ((rc-function (c) `(stack-ref ,c 0 -2 :lisp)) - (rc-interactive (c) `(stack-ref ,c 0 -3 :lisp)) - (rc-test (c) `(stack-ref ,c 0 -4 :lisp)) - (rc-format (c) `(stack-ref ,c 0 -5 :lisp)) - (rc-args (c) `(stack-ref ,c 0 -6 :lisp))) + (macrolet ((rc-function (c) `(stack-frame-ref nil ,c -2 :lisp)) + (rc-interactive (c) `(stack-frame-ref nil ,c -3 :lisp)) + (rc-test (c) `(stack-frame-ref nil ,c -4 :lisp)) + (rc-format (c) `(stack-frame-ref nil ,c -5 :lisp)) + (rc-args (c) `(stack-frame-ref nil ,c -6 :lisp))) (multiple-value-bind ,(cdar basic-restart-clause) (values ,@(subseq `(,context - (stack-ref ,context 0 -1 :lisp)) ; name + (stack-frame-ref nil ,context -1 :lisp)) ; name 0 (length (cdar basic-restart-clause)))) ,@(rest basic-restart-clause)))))) ,@(when catch-clause @@ -135,13 +135,12 @@ (values ,context ,tag) ,@(rest catch-clause)))))))))) -#+ignore (defun pdc (&rest types) (declare (dynamic-extent types)) (let ((types (or types '(:restarts :bindings :catch)))) (with-each-dynamic-context () ((:basic-restart context name) - (when (member :restart types) + (when (member :restarts types) (format t "~&restart: ~S fmt: ~S/~S [#x~X]" name (rc-format context) (rc-args context)