From dcd992a05c75c817760beea4c7f9942e739881f5 Mon Sep 17 00:00:00 2001
From: toy <toy>
Date: Fri, 9 Aug 2002 20:18:47 +0000
Subject: [PATCH] From Eric Marsden:

The idea of using of MACROLET instead of SYMBOL-MACROLET is due to
Bill Newman, and Christophe Rhodes made it work in SBCL.


  * prevent SYMBOL-MACROLET from binding special variables, as per
    CLtS. This requires a change to the (rather ugly) way that the
    assembler uses symbol-macrolet on two special variables that
    contain the current segment and the current vop. We encapsulate
    all accesses to the special variables by macros, and replace the
    symbol-macrolet machinery by a macrolet.
---
 compiler/new-assem.lisp | 71 ++++++++++++++++++++++-------------------
 1 file changed, 39 insertions(+), 32 deletions(-)

diff --git a/compiler/new-assem.lisp b/compiler/new-assem.lisp
index a7ca86b4b..2025d31bd 100644
--- a/compiler/new-assem.lisp
+++ b/compiler/new-assem.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.29 2001/10/31 13:16:38 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.30 2002/08/09 20:18:47 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -49,7 +49,7 @@
 ;;;
 (defmacro def-assembler-params (&rest options)
   "Set up the assembler."
-  `(eval-when (compile load eval)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
      (setf (c:backend-assembler-params c:*target-backend*)
 	   (make-assem-params :backend c:*target-backend*
 			      ,@options))))
@@ -306,7 +306,7 @@
 
 ;;; WITHOUT-SCHEDULING -- interface.
 ;;;
-(defmacro without-scheduling ((&optional (segment '*current-segment*))
+(defmacro without-scheduling ((&optional (segment '(%%current-segment%%)))
 			      &body body)
   "Execute BODY (as a progn) without scheduling any of the instructions
    generated inside it.  DO NOT throw or return-from out of it."
@@ -1304,29 +1304,36 @@
 
 ;;;; Interface to the rest of the compiler.
 
-;;; *CURRENT-SEGMENT* -- internal.
+;;; Macro %%CURRENT-SEGMENT%% -- internal.
 ;;;
-;;; The holds the current segment while assembling.  Use ASSEMBLE to change
-;;; it.
+;;; Returns the current segment while assembling. Use ASSEMBLE to
+;;; change it.
+;;;
+;;; Using a macro to access the underlying special variable
+;;; *CURRENT-SEGMENT* allows us to play scoping tricks in
+;;; DEFINE-INSTRUCTION, to detect calls to the INST macro that aren't
+;;; inside the scope of an ASSEMBLE. 
 ;;; 
 (defvar *current-segment*)
+(defmacro %%current-segment%% () '*current-segment*)
 
-;;; *CURRENT-VOP* -- internal.
+;;; Macro %%CURRENT-VOP%% -- internal.
 ;;;
-;;; Just like *CURRENT-SEGMENT*, but holds the current vop.  Used only to keep
-;;; track of which vops emit which insts.
+;;; Like %%CURRENT-SEGMENT%%, but returns the current vop. Used
+;;; only to keep track of which vops emit which insts.
 ;;; 
 (defvar *current-vop* nil)
+(defmacro %%current-vop%% () '*current-vop*)
 
 ;;; ASSEMBLE -- interface.
 ;;;
-;;; 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 special value becomming
-;;; out of sync with the lexical value.  Unless some bozo closes over it,
-;;; but nobody does anything like that...
-;;;
+;;; Performance optimization: we MACROLET %%CURRENT-SEGMENT%% to a
+;;; local holding the segment so that 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 special value becomming out of sync with
+;;; the lexical value. Unless some bozo closes over it, but nobody
+;;; does anything like that...
 (defmacro assemble ((&optional segment vop &key labels) &body body
 		    &environment env)
   "Execute BODY (as a progn) with SEGMENT as the current segment."
@@ -1348,8 +1355,8 @@
       (when (intersection labels inherited-labels)
 	(error "Duplicate nested labels: ~S"
 	       (intersection labels inherited-labels)))
-      `(let* ((,seg-var ,(or segment '*current-segment*))
-	      (,vop-var ,(or vop '*current-vop*))
+      `(let* ((,seg-var ,(or segment '(%%current-segment%%)))
+              (,vop-var ,(or vop '(%%current-vop%%)))
 	      ,@(when segment
 		  `((*current-segment* ,seg-var)))
 	      ,@(when vop
@@ -1357,15 +1364,16 @@
 	      ,@(mapcar #'(lambda (name)
 			    `(,name (gen-label)))
 			new-labels))
-	 (symbol-macrolet ((*current-segment* ,seg-var)
-			   (*current-vop* ,vop-var)
-			   ,@(when (or inherited-labels nested-labels)
+        (declare (ignorable ,vop-var ,seg-var))
+        (macrolet ((%%current-segment%% () '*current-segment*)
+                   (%%current-vop%% () '*current-vop*))
+          (symbol-macrolet (,@(when (or inherited-labels nested-labels)
 			       `((..inherited-labels.. ,nested-labels))))
 	   ,@(mapcar #'(lambda (form)
 			 (if (label-name-p form)
 			     `(emit-label ,form)
 			     form))
-		     body))))))
+		     body)))))))
 
 ;;; INST -- interface.
 ;;; 
@@ -1379,24 +1387,27 @@
 	  ((functionp inst)
 	   (funcall inst (cdr whole) env))
 	  (t
-	   `(,inst *current-segment* *current-vop* ,@args)))))
+	   `(,inst (%%current-segment%%) (%%current-vop%%) ,@args)))))
 
 ;;; EMIT-LABEL -- interface.
 ;;; 
+;;; Note: The need to capture MACROLET bindings of %%CURRENT-SEGMENT%%
+;;; and %%CURRENT-VOP%% prevents this from being an ordinary function
+;;; (likewise for EMIT-POSTIT and ALIGN, below).
 (defmacro emit-label (label)
   "Emit LABEL at this location in the current segment."
-  `(%emit-label *current-segment* *current-vop* ,label))
+  `(%emit-label (%%current-segment%%) (%%current-vop%%) ,label))
 
 ;;; EMIT-POSTIT -- interface.
 ;;;
 (defmacro emit-postit (function)
-  `(%emit-postit *current-segment* ,function))
+  `(%emit-postit (%%current-segment%%) ,function))
 
 ;;; ALIGN -- interface.
 ;;; 
 (defmacro align (bits &optional (fill-byte 0))
   "Emit an alignment restriction to the current segment."
-  `(emit-alignment *current-segment* *current-vop* ,bits ,fill-byte))
+  `(emit-alignment (%%current-segment%%) (%%current-vop%%) ,bits ,fill-byte))
 
 ;;; LABEL-POSITION -- interface.
 ;;; 
@@ -1808,12 +1819,8 @@
 	       `((declare ,@decls)))
 	   (let ((,postits (segment-postits ,segment-name)))
 	     (setf (segment-postits ,segment-name) nil)
-	     (symbol-macrolet
-		 ((*current-segment*
-		   (macrolet ((lose ()
-				(error "Can't use INST without an ASSEMBLE ~
-					inside emitters.")))
-		     (lose))))
+             (macrolet ((%%current-segment%% ()
+                          (error "You can't use INST without an ASSEMBLE inside emitters.")))
 	       ,@emitter))
 	   (ext:undefined-value))
 	 (eval-when (compile load eval)
-- 
GitLab