0.8.12.7: Merge package locks, AKA "what can go wrong with a 3783 line patch?"

[sbcl.git] / src / compiler / assem.lisp

diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp
index 575ecd8..3a9e453 100644 (file)
--- a/src/compiler/assem.lisp
+++ b/src/compiler/assem.lisp
@@ -156,9 +156,7 @@
 ;;; BACK-PATCH-FUN so we can avoid this nastiness altogether.
 (defmacro with-modified-segment-index-and-posn ((segment index posn)
                                                &body body)
-  (let ((n-segment (gensym "SEGMENT"))
-       (old-index (gensym "OLD-INDEX-"))
-       (old-posn (gensym "OLD-POSN-")))
+  (with-unique-names (n-segment old-index old-posn)
     `(let* ((,n-segment ,segment)
            (,old-index (segment-current-index ,n-segment))
            (,old-posn (segment-current-posn ,n-segment)))
@@ -475,7 +473,7 @@
            ;; nothing to do, then emit a nop. ### Note: despite the
            ;; fact that this is a loop, it really won't work for
            ;; repetitions other then zero and one. For example, if
-p          ;; the branch has two dependents and one of them dpends on
+           ;; the branch has two dependents and one of them dpends on
            ;; the other, then the stuff that grabs a dependent could
            ;; easily grab the wrong one. But I don't feel like fixing
            ;; this because it doesn't matter for any of the
@@ -770,7 +768,7 @@ p       ;; the branch has two dependents and one of them dpends on
   (declare (type segment segment)
           (type annotation note))
   (when (annotation-posn note)
-    (error "attempt to emit ~S a second time"))
+    (error "attempt to emit ~S a second time" note))
   (setf (annotation-posn note) (segment-current-posn segment))
   (setf (annotation-index note) (segment-current-index segment))
   (let ((last (segment-last-annotation segment))
@@ -1165,16 +1163,24 @@ p           ;; the branch has two dependents and one of them dpends on
              ,@(mapcar (lambda (name)
                          `(,name (gen-label)))
                        new-labels))
-       (declare (ignorable ,vop-var ,seg-var))
+       (declare (ignorable ,vop-var ,seg-var)
+                ;; Must be done so that contribs and user code doing
+                ;; low-level stuff don't need to worry about this.
+                (disable-package-locks %%current-segment%% %%current-vop%%))
        (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)))))))
+          ;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least)
+          ;; can't deal with this declaration, so disable it on host.
+          ;; Ditto for later ENABLE-PACKAGE-LOCKS %%C-S%% declaration.
+          #-sb-xc-host
+         (declare (enable-package-locks %%current-segment%% %%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)))))))
 #+sb-xc-host
 (sb!xc:defmacro assemble ((&optional segment vop &key labels)
                          &body body
@@ -1211,13 +1217,13 @@ p           ;; the branch has two dependents and one of them dpends on
        (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)))))))
+         (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)))))))
 
 (defmacro inst (&whole whole instruction &rest args &environment env)
   #!+sb-doc
@@ -1272,8 +1278,7 @@ p     ;; the branch has two dependents and one of them dpends on
     (setf (segment-postits segment) (segment-postits other-segment))
     (dolist (postit postits)
       (emit-back-patch segment 0 postit)))
-  #!-x86 (emit-alignment segment nil max-alignment)
-  #!+x86 (emit-alignment segment nil max-alignment #x90)
+  (emit-alignment segment nil max-alignment #!+(or x86-64 x86) #x90)
   (let ((segment-current-index-0 (segment-current-index segment))
        (segment-current-posn-0  (segment-current-posn  segment)))
     (incf (segment-current-index segment)
@@ -1332,6 +1337,7 @@ p     ;; the branch has two dependents and one of them dpends on
 ;;; calling FUNCTION once on the entire compacted segment buffer. --
 ;;; WHN 19990322
 (defun on-segment-contents-vectorly (segment function)
+  (declare (type function function))
   (let ((buffer (segment-buffer segment))
        (i0 0))
     (flet ((frob (i0 i1)
@@ -1638,10 +1644,19 @@ p           ;; the branch has two dependents and one of them dpends on
           ,@(when decls
               `((declare ,@decls)))
           (let ((,postits (segment-postits ,segment-name)))
+            ;; Must be done so that contribs and user code doing
+            ;; low-level stuff don't need to worry about this.
+            (declare (disable-package-locks %%current-segment%%))
             (setf (segment-postits ,segment-name) nil)
             (macrolet ((%%current-segment%% ()
                          (error "You can't use INST without an ~
                                  ASSEMBLE inside emitters.")))
+               ;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least)
+               ;; can't deal with this declaration, so disable it on host
+               ;; Ditto for earlier ENABLE-PACKAGE-LOCKS %%C-S%% %%C-V%%
+               ;; declaration.
+               #-sb-xc-host
+              (declare (enable-package-locks %%current-segment%%))
               ,@emitter))
           (values))
         (eval-when (:compile-toplevel :load-toplevel :execute)
@@ -1653,8 +1668,7 @@ p     ;; the branch has two dependents and one of them dpends on
                (append ,@(extract-nths 0 'list pdefs)))))))))
 
 (defmacro define-instruction-macro (name lambda-list &body body)
-  (let ((whole (gensym "WHOLE-"))
-       (env (gensym "ENV-")))
+  (with-unique-names (whole env)
     (multiple-value-bind (body local-defs)
        (sb!kernel:parse-defmacro lambda-list
                                  whole