Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv27786
Modified Files:
compiler.lisp
Log Message:
Changed dynamic binding lookup protocol. Only use the "unbounded"
primitive-function, and have the caller check whether the value is the
unbound-value or not. And, rename to dynamic-variable-lookup.
Date: Thu Nov 18 18:58:37 2004
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.107 movitz/compiler.lisp:1.108
--- movitz/compiler.lisp:1.107 Wed Nov 17 14:32:46 2004
+++ movitz/compiler.lisp Thu Nov 18 18:58:35 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.107 2004/11/17 13:32:46 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.108 2004/11/18 17:58:35 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -5602,7 +5602,11 @@
:modifies nil
:final-form form
:code `((:load-constant ,form :eax)
- (:call (:edi ,(global-constant-offset 'dynamic-variable-lookup))))))
+ (,*compiler-local-segment-prefix*
+ :call (:edi ,(global-constant-offset 'dynamic-variable-lookup)))
+ (,*compiler-local-segment-prefix*
+ :cmpl :eax (:edi ,(global-constant-offset 'unbound-value)))
+ (:je '(:sub-program () (:int 99))))))
(t (check-type binding dynamic-binding)
(compiler-values ()
:returns :eax
@@ -5610,7 +5614,11 @@
:modifies nil
:final-form form
:code `((:load-constant ,form :eax)
- (:call (:edi ,(global-constant-offset 'dynamic-variable-lookup))))))))))
+ (,*compiler-local-segment-prefix*
+ :call (:edi ,(global-constant-offset 'dynamic-variable-lookup)))
+ (,*compiler-local-segment-prefix*
+ :cmpl :eax (:edi ,(global-constant-offset 'unbound-value)))
+ (:je '(:sub-program () (:int 99))))))))))
(define-compiler compile-lambda-form (&form form)
"3.1.2.2.4 Lambda Forms"
@@ -6486,3 +6494,38 @@
`((:movl :eax ,destination))))
(binding
(make-store-lexical destination :eax nil frame-map))))))))))
+
+;;;;;;;
+
+(define-find-read-bindings :eql (x y)
+ (list x y))
+
+(define-extended-code-expander :eql (instruction funobj frame-map)
+ (destructuring-bind (x y)
+ (cdr instruction)
+ (let* ((x-type (apply #'encoded-type-decode (binding-store-type x)))
+ (y-type (apply #'encoded-type-decode (binding-store-type y)))
+ (x-singleton (type-specifier-singleton x-type))
+ (y-singleton (type-specifier-singleton y-type)))
+ (when (and y-singleton (not x-singleton))
+ (rotatef x y)
+ (rotatef x-type y-type)
+ (rotatef x-singleton y-singleton))
+ (warn "eql ~S ~S" x-singleton y-singleton)
+ (cond
+ ((and x-singleton y-singleton)
+ (break "Constant EQL: ~S ~S" (car x-singleton) (car y-singleton)))
+ ((or (movitz-subtypep x-type 'fixnum)
+ (movitz-subtypep x-type 'character)
+ (movitz-subtypep y-type 'fixnum)
+ (movitz-subtypep y-type 'character))
+ (break "EQL that is EQ."))
+ (t (append (make-load-lexical x :eax funobj nil frame-map)
+ (make-load-lexical y :ebx funobj nil frame-map)
+ (let ((eql-done (gensym "eql-done-")))
+ `((:cmpl :eax :ebx)
+ (:je ',eql-done)
+ (,*compiler-global-segment-prefix*
+ :movl (:edi ,(global-constant-offset 'complicated-eql)) :esi)
+ (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%2op)))
+ ,eql-done))))))))