Skip to content
Snippets Groups Projects
Commit dcd992a0 authored by toy's avatar toy
Browse files

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.
parent caf7cb8d
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -49,7 +49,7 @@
;;; ;;;
(defmacro def-assembler-params (&rest options) (defmacro def-assembler-params (&rest options)
"Set up the assembler." "Set up the assembler."
`(eval-when (compile load eval) `(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (c:backend-assembler-params c:*target-backend*) (setf (c:backend-assembler-params c:*target-backend*)
(make-assem-params :backend c:*target-backend* (make-assem-params :backend c:*target-backend*
,@options)))) ,@options))))
...@@ -306,7 +306,7 @@ ...@@ -306,7 +306,7 @@
;;; WITHOUT-SCHEDULING -- interface. ;;; WITHOUT-SCHEDULING -- interface.
;;; ;;;
(defmacro without-scheduling ((&optional (segment '*current-segment*)) (defmacro without-scheduling ((&optional (segment '(%%current-segment%%)))
&body body) &body body)
"Execute BODY (as a progn) without scheduling any of the instructions "Execute BODY (as a progn) without scheduling any of the instructions
generated inside it. DO NOT throw or return-from out of it." generated inside it. DO NOT throw or return-from out of it."
...@@ -1304,29 +1304,36 @@ ...@@ -1304,29 +1304,36 @@
;;;; Interface to the rest of the compiler. ;;;; 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 ;;; Returns the current segment while assembling. Use ASSEMBLE to
;;; it. ;;; 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*) (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 ;;; Like %%CURRENT-SEGMENT%%, but returns the current vop. Used
;;; track of which vops emit which insts. ;;; only to keep track of which vops emit which insts.
;;; ;;;
(defvar *current-vop* nil) (defvar *current-vop* nil)
(defmacro %%current-vop%% () '*current-vop*)
;;; ASSEMBLE -- interface. ;;; ASSEMBLE -- interface.
;;; ;;;
;;; We also symbol-macrolet *current-segment* to a local holding the segment ;;; Performance optimization: we MACROLET %%CURRENT-SEGMENT%% to a
;;; so uses of *current-segment* inside the body don't have to keep ;;; local holding the segment so that uses of %%CURRENT-SEGMENT%%
;;; dereferencing the symbol. Given that ASSEMBLE is the only interface to ;;; inside the body don't have to keep dereferencing the symbol. Given
;;; *current-segment*, we don't have to worry about the special value becomming ;;; that ASSEMBLE is the only interface to *CURRENT-SEGMENT*, we don't
;;; out of sync with the lexical value. Unless some bozo closes over it, ;;; have to worry about the special value becomming out of sync with
;;; but nobody does anything like that... ;;; the lexical value. Unless some bozo closes over it, but nobody
;;; ;;; does anything like that...
(defmacro assemble ((&optional segment vop &key labels) &body body (defmacro assemble ((&optional segment vop &key labels) &body body
&environment env) &environment env)
"Execute BODY (as a progn) with SEGMENT as the current segment." "Execute BODY (as a progn) with SEGMENT as the current segment."
...@@ -1348,8 +1355,8 @@ ...@@ -1348,8 +1355,8 @@
(when (intersection labels inherited-labels) (when (intersection labels inherited-labels)
(error "Duplicate nested labels: ~S" (error "Duplicate nested labels: ~S"
(intersection labels inherited-labels))) (intersection labels inherited-labels)))
`(let* ((,seg-var ,(or segment '*current-segment*)) `(let* ((,seg-var ,(or segment '(%%current-segment%%)))
(,vop-var ,(or vop '*current-vop*)) (,vop-var ,(or vop '(%%current-vop%%)))
,@(when segment ,@(when segment
`((*current-segment* ,seg-var))) `((*current-segment* ,seg-var)))
,@(when vop ,@(when vop
...@@ -1357,15 +1364,16 @@ ...@@ -1357,15 +1364,16 @@
,@(mapcar #'(lambda (name) ,@(mapcar #'(lambda (name)
`(,name (gen-label))) `(,name (gen-label)))
new-labels)) new-labels))
(symbol-macrolet ((*current-segment* ,seg-var) (declare (ignorable ,vop-var ,seg-var))
(*current-vop* ,vop-var) (macrolet ((%%current-segment%% () '*current-segment*)
,@(when (or inherited-labels nested-labels) (%%current-vop%% () '*current-vop*))
(symbol-macrolet (,@(when (or inherited-labels nested-labels)
`((..inherited-labels.. ,nested-labels)))) `((..inherited-labels.. ,nested-labels))))
,@(mapcar #'(lambda (form) ,@(mapcar #'(lambda (form)
(if (label-name-p form) (if (label-name-p form)
`(emit-label ,form) `(emit-label ,form)
form)) form))
body)))))) body)))))))
;;; INST -- interface. ;;; INST -- interface.
;;; ;;;
...@@ -1379,24 +1387,27 @@ ...@@ -1379,24 +1387,27 @@
((functionp inst) ((functionp inst)
(funcall inst (cdr whole) env)) (funcall inst (cdr whole) env))
(t (t
`(,inst *current-segment* *current-vop* ,@args))))) `(,inst (%%current-segment%%) (%%current-vop%%) ,@args)))))
;;; EMIT-LABEL -- interface. ;;; 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) (defmacro emit-label (label)
"Emit LABEL at this location in the current segment." "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. ;;; EMIT-POSTIT -- interface.
;;; ;;;
(defmacro emit-postit (function) (defmacro emit-postit (function)
`(%emit-postit *current-segment* ,function)) `(%emit-postit (%%current-segment%%) ,function))
;;; ALIGN -- interface. ;;; ALIGN -- interface.
;;; ;;;
(defmacro align (bits &optional (fill-byte 0)) (defmacro align (bits &optional (fill-byte 0))
"Emit an alignment restriction to the current segment." "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. ;;; LABEL-POSITION -- interface.
;;; ;;;
...@@ -1808,12 +1819,8 @@ ...@@ -1808,12 +1819,8 @@
`((declare ,@decls))) `((declare ,@decls)))
(let ((,postits (segment-postits ,segment-name))) (let ((,postits (segment-postits ,segment-name)))
(setf (segment-postits ,segment-name) nil) (setf (segment-postits ,segment-name) nil)
(symbol-macrolet (macrolet ((%%current-segment%% ()
((*current-segment* (error "You can't use INST without an ASSEMBLE inside emitters.")))
(macrolet ((lose ()
(error "Can't use INST without an ASSEMBLE ~
inside emitters.")))
(lose))))
,@emitter)) ,@emitter))
(ext:undefined-value)) (ext:undefined-value))
(eval-when (compile load eval) (eval-when (compile load eval)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment