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

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.lisp
by Frode Vatvedt Fjeld 19 Apr '04

19 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18714 Modified Files: los-closette-compiler.lisp Log Message: Changed structure-class and defstruct so as to be better integrated with the MOP. This means that the slot-value accessor should now work on structure-objects. Date: Mon Apr 19 18:38:22 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.11 movitz/losp/muerte/los-closette-compiler.lisp:1.12 --- movitz/losp/muerte/los-closette-compiler.lisp:1.11 Sun Feb 15 08:17:55 2004 +++ movitz/losp/muerte/los-closette-compiler.lisp Mon Apr 19 18:38:22 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.11 2004/02/15 13:17:55 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.12 2004/04/19 22:38:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -611,13 +611,13 @@ :direct-superclasses direct-superclasses) class)) - (defun movitz-make-instance (metaclass &rest all-keys) - ;; (warn "movitz-make-instance: ~S ~S" metaclass all-keys) - (when (symbolp metaclass) - (setf metaclass (movitz-find-class metaclass))) - (if (eq metaclass (movitz-find-class 'funcallable-standard-class nil)) - (apply 'movitz-make-instance-funcallable metaclass all-keys) - (let ((instance (std-allocate-instance metaclass))) + (defun movitz-make-instance (class &rest all-keys) + ;; (warn "movitz-make-instance: ~S ~S" class all-keys) + (when (symbolp class) + (setf class (movitz-find-class class))) + (if (eq class (movitz-find-class 'funcallable-standard-class nil)) + (apply 'movitz-make-instance-funcallable class all-keys) + (let ((instance (std-allocate-instance class))) (dolist (slot (class-slots (movitz-class-of instance))) (let ((slot-name (slot-definition-name slot))) (multiple-value-bind (init-key init-value foundp)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/defstruct.lisp
by Frode Vatvedt Fjeld 19 Apr '04

19 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18506 Modified Files: defstruct.lisp Log Message: Changed structure-class and defstruct so as to be better integrated with the MOP. This means that the slot-value accessor should now work on structure-objects. Date: Mon Apr 19 18:38:17 2004 Author: ffjeld Index: movitz/losp/muerte/defstruct.lisp diff -u movitz/losp/muerte/defstruct.lisp:1.6 movitz/losp/muerte/defstruct.lisp:1.7 --- movitz/losp/muerte/defstruct.lisp:1.6 Sun Apr 18 19:16:49 2004 +++ movitz/losp/muerte/defstruct.lisp Mon Apr 19 18:38:16 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jan 22 13:10:59 2001 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defstruct.lisp,v 1.6 2004/04/18 23:16:49 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.7 2004/04/19 22:38:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -294,7 +294,11 @@ (slot-number ,slot-number))) (defclass ,struct-name (structure-object) () (:metaclass structure-class) - (:slots ,canonical-slot-descriptions)) + (:slots ,(loop for (name) in canonical-slot-descriptions + as location upfrom 0 + collect (movitz-make-instance 'structure-slot-definition + :name name + :location location)))) ',struct-name)) (list `(progn @@ -332,10 +336,3 @@ (defun structure-object-name (x) (movitz-accessor x movitz-struct name)) -(defmacro with-accessors (slot-entries instance-form &body declarations-and-forms) - (let ((instance-variable (gensym "with-accessors-instance-"))) - `(let ((,instance-variable ,instance-form)) - (declare (ignorable ,instance-variable)) - (symbol-macrolet ,(loop for (variable-name accessor-name) in slot-entries - collecting `(,variable-name (,accessor-name ,instance-variable))) - ,@declarations-and-forms))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/common-lisp.lisp
by Frode Vatvedt Fjeld 19 Apr '04

19 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18312 Modified Files: common-lisp.lisp Log Message: Changed structure-class and defstruct so as to be better integrated with the MOP. This means that the slot-value accessor should now work on structure-objects. Date: Mon Apr 19 18:38:12 2004 Author: ffjeld Index: movitz/losp/muerte/common-lisp.lisp diff -u movitz/losp/muerte/common-lisp.lisp:1.5 movitz/losp/muerte/common-lisp.lisp:1.6 --- movitz/losp/muerte/common-lisp.lisp:1.5 Sun Apr 18 19:17:04 2004 +++ movitz/losp/muerte/common-lisp.lisp Mon Apr 19 18:38:11 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:41:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: common-lisp.lisp,v 1.5 2004/04/18 23:17:04 ffjeld Exp $ +;;;; $Id: common-lisp.lisp,v 1.6 2004/04/19 22:38:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -34,6 +34,7 @@ (require :muerte/inspect) (require :muerte/strings) (require :muerte/print) +(require :muerte/los-closette) (require :muerte/defstruct) (require :muerte/hash-tables) (require :muerte/packages) @@ -41,7 +42,6 @@ (require :muerte/error) (require :muerte/loop) (require :muerte/eval) -(require :muerte/los-closette) (require :muerte/environment) (require :muerte/streams) (require :muerte/restarts)

1 0

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

19 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18707 Modified Files: compiler.lisp Log Message: Fixed a nasty compiler bug that would overwrite one function-argument with another in certain instances. Date: Mon Apr 19 16:34:56 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.55 movitz/compiler.lisp:1.56 --- movitz/compiler.lisp:1.55 Mon Apr 19 11:02:53 2004 +++ movitz/compiler.lisp Mon Apr 19 16:34:55 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.55 2004/04/19 15:02:53 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.56 2004/04/19 20:34:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3763,10 +3763,7 @@ (let ((required-vars (required-vars env)) (min-args (min-args env)) (max-args (max-args env))) - (let (#+ignore (max-used-arg (loop for (binding) in frame-map - when (typep binding 'positional-function-argument) - maximize (function-argument-argnum binding))) - (stack-setup-size stack-frame-size) + (let ((stack-setup-size stack-frame-size) (edx-needs-saving-p (and (edx-var env) (new-binding-location (edx-var env) frame-map :default nil)))) (multiple-value-bind (eax-ebx-code eax-ebx-code-post-stackframe) @@ -3830,8 +3827,8 @@ after-code `((:movl (:ebp (:ecx 4) ,(* -4 (1- (function-argument-argnum binding)))) - :eax) - (:movl :eax (:ebp ,(stack-frame-offset + :edx) + (:movl :edx (:ebp ,(stack-frame-offset (new-binding-location binding frame-map))))))))))) (values before-code after-code))) (t (values (append @@ -3877,10 +3874,11 @@ append `((:movl (:ebp (:ecx 4) ,(* -4 (1- (function-argument-argnum binding)))) - :eax) - (:movl :eax (:ebp ,(stack-frame-offset + :edx) + (:movl :edx (:ebp ,(stack-frame-offset (new-binding-location binding frame-map))))) - and do (setq need-normalized-ecx-p t)))))) + and do + (setq need-normalized-ecx-p t)))))) (assert (not (minusp stack-setup-size))) (let ((stack-frame-init-code (append (when (and do-check-stack-p use-stack-frame-p @@ -3889,9 +3887,9 @@ `((,*compiler-local-segment-prefix* :bound (:edi ,(global-constant-offset 'stack-bottom)) :esp))) (when use-stack-frame-p - `((:pushl :ebp) - (:movl :esp :ebp) - (:pushl :esi)))))) + `((:pushl :ebp) + (:movl :esp :ebp) + (:pushl :esi)))))) (values (append (cond @@ -4002,7 +4000,7 @@ (:movl :edi (:ebp ,(stack-frame-offset (1+ lended-cons-position)))) ; car (:leal (:ebp 1 ,(stack-frame-offset (1+ lended-cons-position))) :edx) (:movl :edx (:ebp ,(stack-frame-offset location)))))))))) - need-normalized-ecx-p)))))) + need-normalized-ecx-p)))))) (defparameter *restify-stats* (make-hash-table :test #'eql))

1 0

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

19 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11801 Modified Files: more-macros.lisp Log Message: Added macro with-slots. Date: Mon Apr 19 16:01:08 2004 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.5 movitz/losp/muerte/more-macros.lisp:1.6 --- movitz/losp/muerte/more-macros.lisp:1.5 Tue Apr 6 10:05:23 2004 +++ movitz/losp/muerte/more-macros.lisp Mon Apr 19 16:01:08 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.5 2004/04/06 14:05:23 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.6 2004/04/19 20:01:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -292,3 +292,13 @@ (defmacro ignore-errors (&body body) `(handler-case (progn ,@body) (error (c) (values nil c)))) + +(defmacro with-slots (slot-entries instance-form &body declarations-and-forms) + (let ((object-var (gensym "with-slots-object-"))) + `(symbol-macrolet ,(mapcar (lambda (entry) + (let ((var (if (atom entry) entry (car entry))) + (slot (if (atom entry) entry (cadr entry)))) + `(,var (slot-value ,object-var ',slot)))) + slot-entries) + (let ((,object-var ,instance-form)) + ,@declarations-and-forms)))) \ No newline at end of file

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp
by Frode Vatvedt Fjeld 19 Apr '04

19 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18778 Modified Files: typep.lisp Log Message: Added knowledge of the satisfies type in typep's compiler-macro. Date: Mon Apr 19 15:51:01 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.10 movitz/losp/muerte/typep.lisp:1.11 --- movitz/losp/muerte/typep.lisp:1.10 Sat Apr 17 10:08:24 2004 +++ movitz/losp/muerte/typep.lisp Mon Apr 19 15:51:01 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.10 2004/04/17 14:08:24 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.11 2004/04/19 19:51:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -294,6 +294,11 @@ not-fixnum))))))) ((eql) `(eql ,object ',(cadr type))) + ((satisfies) + (destructuring-bind (predicate-name) + (cdr type) + (check-type predicate-name symbol "a satisfies predicate-name") + `(,predicate-name ,object))) ((cons) (destructuring-bind (&optional (car t) (cdr t)) (cdr type)

1 0

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

19 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv31584 Modified Files: primitive-functions.lisp Log Message: Fixed fast-class-of-null and fast-class-of-character so that they actually do what they're supposed to do. Date: Mon Apr 19 15:49:11 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.14 movitz/losp/muerte/primitive-functions.lisp:1.15 --- movitz/losp/muerte/primitive-functions.lisp:1.14 Mon Apr 19 11:06:38 2004 +++ movitz/losp/muerte/primitive-functions.lisp Mon Apr 19 15:49:11 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.14 2004/04/19 15:06:38 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.15 2004/04/19 19:49:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -561,8 +561,12 @@ (define-primitive-function fast-class-of-character () "Return the class of a character object." (with-inline-assembly (:returns :multiple-values) - (:globally (:movl (:edi (:edi-offset classes)) :eax)) - (:movl (:eax #.(movitz::class-object-offset 'character)) :eax) + (:globally (:movl (:edi (:edi-offset classes)) :ebx)) + (:cmpb #.(movitz:tag :character) :al) + (:jne '(:sub-program () + (:globally (:movl (:edi (:edi-offset complicated-class-of)) :esi)) + (:jmp (:esi #.(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%1op))))) + (:movl (:ebx #.(movitz::class-object-offset 'character)) :eax) (:ret))) (define-primitive-function fast-class-of-null ()

1 0

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

19 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23371 Modified Files: primitive-functions.lisp Log Message: Changed the way (find-class '<foo>) is optimized for certain well-known classes. The idea is to avoid the normal hash-table lookup for some often-named classes. Date: Mon Apr 19 11:06:38 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.13 movitz/losp/muerte/primitive-functions.lisp:1.14 --- movitz/losp/muerte/primitive-functions.lisp:1.13 Fri Apr 16 19:35:29 2004 +++ movitz/losp/muerte/primitive-functions.lisp Mon Apr 19 11:06:38 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.13 2004/04/16 23:35:29 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.14 2004/04/19 15:06:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -519,21 +519,32 @@ (define-primitive-function fast-class-of-even-fixnum () "Return the class of a fixnum object." (with-inline-assembly (:returns :multiple-values) - (:globally (:movl (:edi (:edi-offset the-class-fixnum)) :eax)) + (:globally (:movl (:edi (:edi-offset classes)) :eax)) + (:movl (:eax #.(movitz::class-object-offset 'fixnum)) :eax) (:ret))) (define-primitive-function fast-class-of-odd-fixnum () "Return the class of a fixnum object." (with-inline-assembly (:returns :multiple-values) - (:globally (:movl (:edi (:edi-offset the-class-fixnum)) :eax)) + (:globally (:movl (:edi (:edi-offset classes)) :eax)) + (:movl (:eax #.(movitz::class-object-offset 'fixnum)) :eax) (:ret))) (define-primitive-function fast-class-of-cons () "Return the class of a cons object." (with-inline-assembly (:returns :multiple-values) - (:globally (:movl (:edi (:edi-offset the-class-cons)) :eax)) + (:globally (:movl (:edi (:edi-offset classes)) :eax)) + (:movl (:eax #.(movitz::class-object-offset 'cons)) :eax) (:ret))) +(define-primitive-function fast-class-of-symbol () + "Return the class of a symbol object." + (with-inline-assembly (:returns :multiple-values) + (:globally (:movl (:edi (:edi-offset classes)) :eax)) + (:movl (:eax #.(movitz::class-object-offset 'symbol)) :eax) + (:ret))) + + (define-primitive-function fast-class-of-std-instance () "Return the class of a std-instance object." (with-inline-assembly (:returns :multiple-values) @@ -550,19 +561,23 @@ (define-primitive-function fast-class-of-character () "Return the class of a character object." (with-inline-assembly (:returns :multiple-values) - (:globally (:movl (:edi (:edi-offset complicated-class-of)) :esi)) - (:jmp (:esi #.(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%1op))))) + (:globally (:movl (:edi (:edi-offset classes)) :eax)) + (:movl (:eax #.(movitz::class-object-offset 'character)) :eax) + (:ret))) (define-primitive-function fast-class-of-null () "Return the class of a nil object." (with-inline-assembly (:returns :multiple-values) - (:globally (:movl (:edi (:edi-offset the-class-null)) :eax)) + (:cmpl :edi :eax) + (:jne '(:sub-program () (:int 64))) + (:globally (:movl (:edi (:edi-offset classes)) :eax)) + (:movl (:eax #.(movitz::class-object-offset 'null)) :eax) (:ret))) (define-primitive-function fast-class-of-other () "Return the class of an other object." (with-inline-assembly (:returns :multiple-values) - (:movw (:eax -2) :cx) + (:movl (:eax -2) :ecx) (:cmpb #.(movitz::tag :std-instance) :cl) (:jne 'not-std-instance) (:movl (:eax #.(bt:slot-offset 'movitz::movitz-std-instance 'movitz::class)) :eax) @@ -579,12 +594,6 @@ (:globally (:movl (:edi (:edi-offset complicated-class-of)) :esi)) (:jmp (:esi #.(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%1op))))) -(define-primitive-function fast-class-of-symbol () - "Return the class of a symbol object." - (with-inline-assembly (:returns :multiple-values) - (:globally (:movl (:edi (:edi-offset the-class-symbol)) :eax)) - (:ret))) - (defun complicated-class-of (object) (typecase object (std-instance @@ -595,7 +604,7 @@ (find-class 'string)) (vector (find-class 'vector)) - (compiled-function + (function (find-class 'function)) (structure-object (find-class (structure-object-name object)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp
by Frode Vatvedt Fjeld 19 Apr '04

19 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19544 Modified Files: los-closette.lisp Log Message: Changed the way (find-class '<foo>) is optimized for certain well-known classes. The idea is to avoid the normal hash-table lookup for some often-named classes. Date: Mon Apr 19 11:06:32 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.7 movitz/losp/muerte/los-closette.lisp:1.8 --- movitz/losp/muerte/los-closette.lisp:1.7 Wed Apr 14 18:01:30 2004 +++ movitz/losp/muerte/los-closette.lisp Mon Apr 19 11:06:32 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.7 2004/04/14 22:01:30 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.8 2004/04/19 15:06:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -208,12 +208,17 @@ (defun (setf find-class) (class class-name) (check-type class (or null class)) + #+ignore (case class-name ((t) (setf (%run-time-context-slot 'the-class-t) class)) (null (setf (%run-time-context-slot 'the-class-null) class)) (symbol (setf (%run-time-context-slot 'the-class-symbol) class)) (fixnum (setf (%run-time-context-slot 'the-class-fixnum) class)) (cons (setf (%run-time-context-slot 'the-class-cons) class))) + (let ((map (load-global-constant classes))) + (when (member class-name (svref map 0)) + (setf (svref map (1+ (position class-name (svref map 0)))) + class))) (if class (setf (gethash class-name *class-table*) class) (remhash class-name *class-table*)) @@ -896,9 +901,6 @@ `(defun ,name (instance) (with-inline-assembly (:returns :multiple-values) (:compile-form (:result-mode :eax) instance) -;;; (:leal (:eax -2) :ecx) -;;; (:testb 7 :cl) -;;; (:jnz '(:sub-program () (:int 68))) (:movl (:eax ,(bt:slot-offset 'movitz::movitz-std-instance 'movitz::slots)) :eax) (:movl (:eax ,(+ (bt:slot-offset 'movitz::movitz-vector 'movitz::data) @@ -1776,11 +1778,6 @@ (warn "CLOS was already bootstrapped: ~S" (get 'clos-bootstrap 'have-bootstrapped))) (setf (get 'clos-bootstrap 'have-bootstrapped) :in-progress) - #+ignore - (setf (runtime-context-slot 'the-class-t) (gethash 't *class-table*) - (runtime-context-slot 'the-class-null) (gethash 'null *class-table*) - (runtime-context-slot 'the-class-symbol) (gethash 'symbol *class-table*) - (runtime-context-slot 'the-class-cons) (gethash 'cons *class-table*)) (let ((real-camuc #'compute-applicable-methods-using-classes) (real-class-slots #'class-slots) (real-class-precedence-list #'class-precedence-list)

1 0

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

19 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11596 Modified Files: basic-macros.lisp Log Message: Changed the way (find-class '<foo>) is optimized for certain well-known classes. The idea is to avoid the normal hash-table lookup for some often-named classes. Date: Mon Apr 19 11:06:26 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.16 movitz/losp/muerte/basic-macros.lisp:1.17 --- movitz/losp/muerte/basic-macros.lisp:1.16 Sun Apr 18 19:15:53 2004 +++ movitz/losp/muerte/basic-macros.lisp Mon Apr 19 11:06: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.16 2004/04/18 23:15:53 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.17 2004/04/19 15:06:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -860,13 +860,26 @@ (declare (ignore errorp)) (if (not (movitz:movitz-constantp symbol env)) form - (case (movitz::translate-program (movitz::eval-form symbol env) :muerte.cl :cl) - ((t) `(load-global-constant the-class-t)) - (fixnum '(load-global-constant the-class-fixnum)) - (null `(load-global-constant the-class-null)) - (symbol '(load-global-constant the-class-symbol)) - (cons '(load-global-constant the-class-cons)) - (t form)))) + (let* ((type (movitz:movitz-eval symbol env)) + (cl-type (movitz::translate-program type :muerte.cl :cl))) + (cond + ((eq t cl-type) + `(load-global-constant the-class-t)) + ((member type (movitz::image-classes-map movitz:*image*)) + `(with-inline-assembly (:returns :register) + (:globally (:movl (:edi (:edi-offset classes)) (:result-register))) + (:movl ((:result-register) ,(movitz::class-object-offset type)) + (:result-register)))) + (t (warn "unknown find-class: ~A" cl-type) + form)) + #+ignore + (case cl-type + ((t) `(load-global-constant the-class-t)) + (fixnum '(load-global-constant the-class-fixnum)) + (null `(load-global-constant the-class-null)) + (symbol '(load-global-constant the-class-symbol)) + (cons '(load-global-constant the-class-cons)) + (t form))))) (define-compiler-macro class-of (object) `(with-inline-assembly (:returns :eax) @@ -886,7 +899,7 @@ (:leal ((:result-register) ,(- (movitz::tag :other))) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program () (:int 68))) + (:jnz '(:sub-program () (:int 66))) (:movl ((:result-register) ,(bt:slot-offset 'movitz::movitz-std-instance slot)) (:result-register)))))) @@ -898,7 +911,7 @@ (:leal (:ebx ,(- (movitz::tag :other))) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program () (:int 68))) + (:jnz '(:sub-program () (:int 66))) (:movl :eax (:ebx ,(bt:slot-offset 'movitz::movitz-std-instance slot))))))) @@ -982,11 +995,6 @@ (:locally (:movl (:edi (:edi-offset ,name)) :ecx))) `(with-inline-assembly (:returns :untagged-fixnum-ecx) (:globally (:movl (:edi (:edi-offset ,name)) :ecx))))) - -;;;(define-compiler-macro (setf %runtime-context-slot) (value slot-name) -;;; `(with-inline-assembly (:returns :eax) -;;; (:compile-form (:result-mode :eax) ,value) -;;; (:movl :eax (:edi ,(movitz::global-constant-offset (movitz::eval-form slot-name)))))) (define-compiler-macro halt-cpu () (let ((infinite-loop-label (make-symbol "infinite-loop")))

1 0