movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

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

18 Aug '04

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)

1 0

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

18 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-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 <frodef(a)acm.org> ;;;; 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 <variable-name> <value>) according to <env>. Return <value>." + (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)

1 0

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

18 Aug '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8448 Modified Files: integers.lisp Log Message: Make (* <fixnum> <bignum>) 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))))

1 0

[movitz-cvs] CVS update: public_html/index.html
by Frode Vatvedt Fjeld 18 Aug '04

18 Aug '04

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 @@ <h3>Most recent news</h3> + <p> <i>August 18, 2004:</i> Movitz finally runs in <a + href="http://fabrice.bellard.free.fr/qemu/">QEMU</a>, 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 <tt>bounds</tt> instruction, which didn't agree + with Movitz, and which is now fixed in QEMU's CVS. + <p> <i>July 8, 2004:</i> The data-structure for vectors has been changed. The vectors length is now represented by a fixnum, increasing the maximum length from <tt>#xffff</tt> to

1 0

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

18 Aug '04

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

1 0

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

16 Aug '04

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 <frodef(a)acm.org> ;;;; 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)

1 0

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

16 Aug '04

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 <frodef(a)acm.org> ;;;; 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)

1 0

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

16 Aug '04

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)

1 0

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

16 Aug '04

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 <frodef(a)acm.org> ;;;; 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))

1 0

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

16 Aug '04

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 <frodef(a)acm.org> ;;;; 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: "

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs