Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory usw-pr-cvs1:/tmp/cvs-serv1348/src/compiler

Modified Files:
	assem.lisp dump.lisp ir1tran.lisp seqtran.lisp 
	trace-table.lisp 
Log Message:
0.7.3.1:
	finally getting to CLISP bootstrapping...
	...merged CSR patch "more controversial fixes" from "Re: CLISP
		compilation" sbcl-devel 2002-04-15 (which don't look
		very controversial except for the **CURRENT-SEGMENT**
		code, which is going to have to be fixed somehow and
		for which this fix looks plausible)
	...made comment fixes mostly related to CSR patch
	...fixed "#+"-should-be-"#!+" typos in parms.lisp


Index: assem.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/assem.lisp,v
retrieving revision 1.13
retrieving revision 1.14
diff -C2 -d -r1.13 -r1.14
*** assem.lisp	12 Jan 2002 19:33:14 -0000	1.13
--- assem.lisp	25 Apr 2002 19:26:55 -0000	1.14
***************
*** 202,206 ****
  ;;;; the scheduler itself
  
! (defmacro without-scheduling ((&optional (segment '**current-segment**))
  			      &body body)
    #!+sb-doc
--- 202,206 ----
  ;;;; the scheduler itself
  
! (defmacro without-scheduling ((&optional (segment '(%%current-segment%%)))
  			      &body body)
    #!+sb-doc
***************
*** 1049,1059 ****
  ;;; change it.
  ;;;
! ;;; The double asterisks in the name are intended to suggest that this
  ;;; isn't just any old special variable, it's an extra-special
  ;;; variable, because sometimes MACROLET is used to bind it. So be
  ;;; careful out there..
  (defvar **current-segment**)
  
! ;;; Just like **CURRENT-SEGMENT**, except this holds the current vop.
  ;;; Used only to keep track of which vops emit which insts.
  ;;;
--- 1049,1069 ----
  ;;; change it.
  ;;;
! ;;; The double parens in the name are intended to suggest that this
  ;;; isn't just any old special variable, it's an extra-special
  ;;; variable, because sometimes MACROLET is used to bind it. So be
  ;;; careful out there..
+ ;;;
+ ;;; (This used to be called **CURRENT-SEGMENT** in SBCL until 0.7.3,
+ ;;; and just *CURRENT-SEGMENT* in CMU CL. In both cases, the rebinding
+ ;;; now done with MACROLET was done with SYMBOL-MACROLET instead. The
+ ;;; rename-with-double-asterisks was because the SYMBOL-MACROLET made
+ ;;; it an extra-special variable. The change over to
+ ;;; %%CURRENT-SEGMENT%% was because ANSI forbids the use of
+ ;;; SYMBOL-MACROLET on special variable names, and CLISP correctly
+ ;;; complains about this when being used as a bootstrap host.)
+ (defmacro %%current-segment%% () '**current-segment**)
  (defvar **current-segment**)
  
! ;;; Just like %%CURRENT-SEGMENT%%, except this holds the current vop.
  ;;; Used only to keep track of which vops emit which insts.
  ;;;
***************
*** 1062,1069 ****
  ;;; variable, because sometimes MACROLET is used to bind it. So be
  ;;; careful out there..
  (defvar **current-vop** nil)
  
! ;;; We also SYMBOL-MACROLET **CURRENT-SEGMENT** to a local holding the
! ;;; segment so uses of **CURRENT-SEGMENT** inside the body don't have
  ;;; to keep dereferencing the symbol. Given that ASSEMBLE is the only
  ;;; interface to **CURRENT-SEGMENT**, we don't have to worry about the
--- 1072,1080 ----
  ;;; variable, because sometimes MACROLET is used to bind it. So be
  ;;; careful out there..
+ (defmacro %%current-vop%% () '**current-vop**)
  (defvar **current-vop** nil)
  
! ;;; We also MACROLET %%CURRENT-SEGMENT%% to a local holding the
! ;;; segment so uses of %%CURRENT-SEGMENT%% inside the body don't have
  ;;; to keep dereferencing the symbol. Given that ASSEMBLE is the only
  ;;; interface to **CURRENT-SEGMENT**, we don't have to worry about the
***************
*** 1105,1120 ****
  	(error "duplicate nested labels: ~S"
  	       (intersection labels inherited-labels)))
!       `(let* ((,seg-var ,(or segment '**current-segment**))
! 	      (,vop-var ,(or vop '**current-vop**))
! 	      ,@(when segment
! 		  `((**current-segment** ,seg-var)))
! 	      ,@(when vop
! 		  `((**current-vop** ,vop-var)))
  	      ,@(mapcar (lambda (name)
  			  `(,name (gen-label)))
  			new-labels))
! 	 (symbol-macrolet ((**current-segment** ,seg-var)
! 			   (**current-vop** ,vop-var)
! 			   ,@(when (or inherited-labels nested-labels)
  			       `((..inherited-labels.. ,nested-labels))))
  	   ,@(mapcar (lambda (form)
--- 1116,1131 ----
  	(error "duplicate nested labels: ~S"
  	       (intersection labels inherited-labels)))
!       `(let* ((,seg-var ,(or segment '(%%current-segment%%)))
! 	      (,vop-var ,(or vop '(%%current-vop%%)))
!               ,@(when segment
!                   `((**current-segment** ,seg-var)))
!               ,@(when vop
!                   `((**current-vop** ,vop-var)))
  	      ,@(mapcar (lambda (name)
  			  `(,name (gen-label)))
  			new-labels))
! 	(macrolet ((%%current-segment%% () '**current-segment**)
! 		   (%%current-vop%% () '**current-vop**))
! 	 (symbol-macrolet (,@(when (or inherited-labels nested-labels)
  			       `((..inherited-labels.. ,nested-labels))))
  	   ,@(mapcar (lambda (form)
***************
*** 1122,1126 ****
  			   `(emit-label ,form)
  			   form))
! 		     body))))))
  #+sb-xc-host
  (sb!xc:defmacro assemble ((&optional segment vop &key labels)
--- 1133,1137 ----
  			   `(emit-label ,form)
  			   form))
! 		     body)))))))
  #+sb-xc-host
  (sb!xc:defmacro assemble ((&optional segment vop &key labels)
***************
*** 1147,1162 ****
  	(error "duplicate nested labels: ~S"
  	       (intersection labels inherited-labels)))
!       `(let* ((,seg-var ,(or segment '**current-segment**))
! 	      (,vop-var ,(or vop '**current-vop**))
! 	      ,@(when segment
! 		  `((**current-segment** ,seg-var)))
! 	      ,@(when vop
! 		  `((**current-vop** ,vop-var)))
  	      ,@(mapcar (lambda (name)
  			  `(,name (gen-label)))
  			new-labels))
! 	 (symbol-macrolet ((**current-segment** ,seg-var)
! 			   (**current-vop** ,vop-var)
! 			   ,@(when (or inherited-labels nested-labels)
  			       `((..inherited-labels.. ,nested-labels))))
  	   ,@(mapcar (lambda (form)
--- 1158,1173 ----
  	(error "duplicate nested labels: ~S"
  	       (intersection labels inherited-labels)))
!       `(let* ((,seg-var ,(or segment '(%%current-segment%%)))
! 	      (,vop-var ,(or vop '(%%current-vop%%)))
!               ,@(when segment
!                   `((**current-segment** ,seg-var)))
!               ,@(when vop
!                   `((**current-vop** ,vop-var)))
  	      ,@(mapcar (lambda (name)
  			  `(,name (gen-label)))
  			new-labels))
! 	(macrolet ((%%current-segment%% () '**current-segment**)
! 		   (%%current-vop%% () '**current-vop**))
! 	 (symbol-macrolet (,@(when (or inherited-labels nested-labels)
  			       `((..inherited-labels.. ,nested-labels))))
  	   ,@(mapcar (lambda (form)
***************
*** 1164,1168 ****
  			   `(emit-label ,form)
  			   form))
! 		     body))))))
  
  (defmacro inst (&whole whole instruction &rest args &environment env)
--- 1175,1179 ----
  			   `(emit-label ,form)
  			   form))
! 		     body)))))))
  
  (defmacro inst (&whole whole instruction &rest args &environment env)
***************
*** 1175,1179 ****
  	   (funcall inst (cdr whole) env))
  	  (t
! 	   `(,inst **current-segment** **current-vop** ,@args)))))
  
  ;;; Note: The need to capture SYMBOL-MACROLET bindings of
--- 1186,1190 ----
  	   (funcall inst (cdr whole) env))
  	  (t
! 	   `(,inst (%%current-segment%%) (%%current-vop%%) ,@args)))))
  
  ;;; Note: The need to capture SYMBOL-MACROLET bindings of
***************
*** 1183,1200 ****
    #!+sb-doc
    "Emit LABEL at this location in the current segment."
!   `(%emit-label **current-segment** **current-vop** ,label))
  
  ;;; Note: The need to capture SYMBOL-MACROLET bindings of
  ;;; **CURRENT-SEGMENT* prevents this from being an ordinary function.
  (defmacro emit-postit (function)
!   `(%emit-postit **current-segment** ,function))
  
  ;;; Note: The need to capture SYMBOL-MACROLET bindings of
! ;;; **CURRENT-SEGMENT* and **CURRENT-VOP** prevents this from being an
  ;;; ordinary function.
  (defmacro align (bits &optional (fill-byte 0))
    #!+sb-doc
    "Emit an alignment restriction to the current segment."
!   `(emit-alignment **current-segment** **current-vop** ,bits ,fill-byte))
  ;;; FIXME: By analogy with EMIT-LABEL and EMIT-POSTIT, this should be
  ;;; called EMIT-ALIGNMENT, and the function that it calls should be
--- 1194,1211 ----
    #!+sb-doc
    "Emit LABEL at this location in the current segment."
!   `(%emit-label (%%current-segment%%) (%%current-vop%%) ,label))
  
  ;;; Note: The need to capture SYMBOL-MACROLET bindings of
  ;;; **CURRENT-SEGMENT* prevents this from being an ordinary function.
  (defmacro emit-postit (function)
!   `(%emit-postit (%%current-segment%%) ,function))
  
  ;;; Note: The need to capture SYMBOL-MACROLET bindings of
! ;;; **CURRENT-SEGMENT* and (%%CURRENT-VOP%%) prevents this from being an
  ;;; ordinary function.
  (defmacro align (bits &optional (fill-byte 0))
    #!+sb-doc
    "Emit an alignment restriction to the current segment."
!   `(emit-alignment (%%current-segment%%) (%%current-vop%%) ,bits ,fill-byte))
  ;;; FIXME: By analogy with EMIT-LABEL and EMIT-POSTIT, this should be
  ;;; called EMIT-ALIGNMENT, and the function that it calls should be
***************
*** 1587,1606 ****
  	   (let ((,postits (segment-postits ,segment-name)))
  	     (setf (segment-postits ,segment-name) nil)
! 	     (symbol-macrolet
! 		 (;; Apparently this binding is intended to keep
! 		  ;; anyone from accidentally using
! 		  ;; **CURRENT-SEGMENT** within the body of the
! 		  ;; emitter. The error message sorta suggests that
! 		  ;; this can happen accidentally by including one
! 		  ;; emitter inside another. But I dunno.. -- WHN
! 		  ;; 19990323
! 		  (**current-segment**
! 		   ;; FIXME: I can't see why we have to use
! 		   ;;   (MACROLET ((LOSE () (ERROR ..))) (LOSE))
! 		   ;; instead of just (ERROR "..") here.
! 		   (macrolet ((lose ()
! 				(error "You can't use INST without an ~
! 					ASSEMBLE inside emitters.")))
! 		     (lose))))
  	       ,@emitter))
  	   (values))
--- 1598,1604 ----
  	   (let ((,postits (segment-postits ,segment-name)))
  	     (setf (segment-postits ,segment-name) nil)
! 	     (macrolet ((%%current-segment%% ()
! 			  (error "You can't use INST without an ~
! 				  ASSEMBLE inside emitters.")))
  	       ,@emitter))
  	   (values))

Index: dump.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/dump.lisp,v
retrieving revision 1.30
retrieving revision 1.31
diff -C2 -d -r1.30 -r1.31
*** dump.lisp	15 Feb 2002 17:10:02 -0000	1.30
--- dump.lisp	25 Apr 2002 19:26:55 -0000	1.31
***************
*** 566,570 ****
  (defun dump-package (pkg file)
    (declare (type package pkg) (type fasl-output file))
!   (declare (values index))
    (declare (inline assoc))
    (cond ((cdr (assoc pkg (fasl-output-packages file) :test #'eq)))
--- 566,570 ----
  (defun dump-package (pkg file)
    (declare (type package pkg) (type fasl-output file))
!   #+nil (declare (values index))
    (declare (inline assoc))
    (cond ((cdr (assoc pkg (fasl-output-packages file) :test #'eq)))

Index: ir1tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran.lisp,v
retrieving revision 1.76
retrieving revision 1.77
diff -C2 -d -r1.76 -r1.77
*** ir1tran.lisp	1 Apr 2002 14:52:23 -0000	1.76
--- ir1tran.lisp	25 Apr 2002 19:26:55 -0000	1.77
***************
*** 127,131 ****
  (defun find-free-fun (name context)
    (declare (string context))
!   (declare (values global-var))
    (or (let ((old-free-fun (gethash name *free-funs*)))
  	(and (not (invalid-free-fun-p old-free-fun))
--- 127,131 ----
  (defun find-free-fun (name context)
    (declare (string context))
!   #+nil (declare (values global-var))
    (or (let ((old-free-fun (gethash name *free-funs*)))
  	(and (not (invalid-free-fun-p old-free-fun))
***************
*** 173,177 ****
  ;;; *FREE-VARS*. If the variable is unknown, then we emit a warning.
  (defun find-free-var (name)
!   (declare (values (or leaf cons heap-alien-info))) ; see FIXME comment
    (unless (symbolp name)
      (compiler-error "Variable name is not a symbol: ~S." name))
--- 173,177 ----
  ;;; *FREE-VARS*. If the variable is unknown, then we emit a warning.
  (defun find-free-var (name)
!   #+nil (declare (values (or leaf cons heap-alien-info))) ; see FIXME comment
    (unless (symbolp name)
      (compiler-error "Variable name is not a symbol: ~S." name))

Index: seqtran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/seqtran.lisp,v
retrieving revision 1.25
retrieving revision 1.26
diff -C2 -d -r1.25 -r1.26
*** seqtran.lisp	17 Apr 2002 02:19:38 -0000	1.25
--- seqtran.lisp	25 Apr 2002 19:26:55 -0000	1.26
***************
*** 606,609 ****
--- 606,618 ----
  ;;;; rather than restricting them to STRINGs only.
  
+ ;;; Moved here from generic/vm-tran.lisp to satisfy clisp
+ ;;;
+ ;;; FIXME: It would be good to implement SB!XC:DEFCONSTANT, and use
+ ;;; use that here, so that the compiler is born knowing this value.
+ ;;; FIXME: Add a comment telling whether this holds for all vectors
+ ;;; or only for vectors based on simple arrays (non-adjustable, etc.).
+ (defconstant vector-data-bit-offset
+   (* sb!vm:vector-data-offset sb!vm:n-word-bits))
+ 
  ;;; FIXME: Shouldn't we be testing for legality of
  ;;;   * START1, START2, END1, and END2 indices?

Index: trace-table.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/trace-table.lisp,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** trace-table.lisp	11 Oct 2001 14:05:25 -0000	1.6
--- trace-table.lisp	25 Apr 2002 19:26:55 -0000	1.7
***************
*** 13,16 ****
--- 13,17 ----
  
  (defun trace-table-entry (state)
+   (declare (special *trace-table-info*))
    (let ((label (gen-label)))
      (emit-label label)