[movitz-cvs] CVS update: movitz/compiler.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv22897

Modified Files:
	compiler.lisp 
Log Message:
*** empty log message ***
Date: Wed Nov 10 16:31:58 2004
Author: ffjeld

Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.102 movitz/compiler.lisp:1.103
--- movitz/compiler.lisp:1.102	Thu Oct 21 22:38:28 2004
+++ movitz/compiler.lisp	Wed Nov 10 16:31:58 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.102 2004/10/21 20:38:28 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.103 2004/11/10 15:31:58 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -47,7 +47,7 @@
 (defparameter *compiler-physical-segment-prefix* '(:gs-override)
   "Use this instruction prefix when accessing a physical memory location (i.e. typically some memory-mapped hardware device).")
 
-(defparameter *compiler-nonlocal-lispval-read-segment-prefix* '(:fs-override)
+(defparameter *compiler-nonlocal-lispval-read-segment-prefix* '()
   "Use this segment prefix when reading a lispval at (potentially)
 non-local locations.")
 
@@ -55,6 +55,11 @@
   "Use this segment prefix when writing a lispval at (potentially)
 non-local locations.")
 
+(defparameter *compiler-use-cons-reader-segment-protocol-p* nil)
+
+(defparameter *compiler-cons-read-segment-prefix* '(:gs-override)
+  "Use this segment prefix for CAR and CDR, when using cons-reader protocol.")
+
 (defvar *compiler-allow-untagged-word-bits* 0
   "Allow (temporary) untagged values of this bit-size to exist, because
 the system ensures one way or another that there can be no pointers below
@@ -6187,20 +6192,35 @@
 	(cond
 	 ((and binding-is-list-p
 	       (member location '(:eax :ebx :ecx :edx)))
-	  `((:movl (,location ,op-offset) ,dst)))
+	  `(,*compiler-nonlocal-lispval-read-segment-prefix*
+	    (:movl (,location ,op-offset) ,dst)))
 	 (binding-is-list-p
 	  `(,@(make-load-lexical binding dst funobj nil frame-map)
-	      (:movl (,dst ,op-offset) ,dst)))
-	 ((eq location :ebx)
-	  `((,*compiler-global-segment-prefix*
-	     :call (:edi ,(global-constant-offset fast-op-ebx)))
-	    ,@(when (not (eq dst :eax))
-		`((:movl :eax ,dst)))))
-	 (t `(,@(make-load-lexical binding :eax funobj nil frame-map)
-		(,*compiler-global-segment-prefix* 
-		 :call (:edi ,(global-constant-offset fast-op)))
-		,@(when (not (eq dst :eax))
-		    `((:movl :eax ,dst))))))))))
+	      (,*compiler-nonlocal-lispval-read-segment-prefix*
+	       :movl (,dst ,op-offset) ,dst)))
+	 ((not *compiler-use-cons-reader-segment-protocol-p*)
+	  (cond
+	   ((eq location :ebx)
+	    `((,*compiler-global-segment-prefix*
+	       :call (:edi ,(global-constant-offset fast-op-ebx)))
+	      ,@(when (not (eq dst :eax))
+		  `((:movl :eax ,dst)))))
+	   (t `(,@(make-load-lexical binding :eax funobj nil frame-map)
+		  (,*compiler-global-segment-prefix* 
+		   :call (:edi ,(global-constant-offset fast-op)))
+		  ,@(when (not (eq dst :eax))
+		      `((:movl :eax ,dst)))))))
+	 (t (cond
+	     ((member location '(:ebx :ecx :edx))
+	      `((,(or *compiler-cons-read-segment-prefix*
+		      *compiler-nonlocal-lispval-read-segment-prefix*)
+		 :movl (:eax ,op-offset) ,dst)))
+	     (t (append (make-load-lexical binding :eax funobj nil frame-map)
+			`((,(or *compiler-cons-read-segment-prefix*
+				*compiler-nonlocal-lispval-read-segment-prefix*)
+			   :movl (:eax ,op-offset) ,dst)))))))))))
+
+	     
 
 
 ;;;;;;;;;;;;;;;;;; endp