1.0.16.10: function-ify ERROR-CALL and GENERATE-ERROR-CODE on x86

[sbcl.git] / src / compiler / x86 / macros.lisp

diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp
index 4c1fba6..bfdb6c8 100644 (file)
--- a/src/compiler/x86/macros.lisp
+++ b/src/compiler/x86/macros.lisp
@@ -294,6 +294,32 @@
       ,@forms)))
 \f
 ;;;; error code
+(defun emit-error-break (vop kind code values)
+  (assemble ()
+    #-darwin
+    (inst int 3)                        ; i386 breakpoint instruction
+    ;; CLH 20060314
+    ;; On Darwin, we need to use #x0b0f instead of int3 in order
+    ;; to generate a SIGILL instead of a SIGTRAP as darwin/x86
+    ;; doesn't seem to be reliably firing SIGTRAP
+    ;; handlers. Hopefully this will be fixed by Apple at a
+    ;; later date.
+    #+darwin
+    (inst word #x0b0f)
+    (when vop
+      (note-this-location vop :internal-error))
+    (inst byte kind)                    ; e.g. trap_xyyy
+    (with-adjustable-vector (vector)    ; interr arguments
+      (write-var-integer code vector)
+      (dolist (tn values)
+        (write-var-integer (make-sc-offset (sc-number (tn-sc tn))
+                                           (or (tn-offset tn) 0))
+                           vector))
+      (inst byte (length vector))
+      (dotimes (i (length vector))
+        (inst byte (aref vector i))))))
+
+#+nil
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   (defun emit-error-break (vop kind code values)
     (let ((vector (gensym)))
@@ -328,21 +354,20 @@
           (dotimes (i (length ,vector))
             (inst byte (aref ,vector i))))))))
 
-(defmacro error-call (vop error-code &rest values)
+(defun error-call (vop error-code &rest values)
   #!+sb-doc
   "Cause an error. ERROR-CODE is the error to cause."
-  (cons 'progn
-        (emit-error-break vop error-trap error-code values)))
+  (emit-error-break vop error-trap (error-number-or-lose error-code) values))
 
-(defmacro generate-error-code (vop error-code &rest values)
+(defun generate-error-code (vop error-code &rest values)
   #!+sb-doc
   "Generate-Error-Code Error-code Value*
   Emit code for an error with the specified Error-Code and context Values."
-  `(assemble (*elsewhere*)
-     (let ((start-lab (gen-label)))
-       (emit-label start-lab)
-       (error-call ,vop ,error-code ,@values)
-       start-lab)))
+  (assemble (*elsewhere*)
+    (let ((start-lab (gen-label)))
+      (emit-label start-lab)
+      (emit-error-break vop error-trap (error-number-or-lose error-code) values)
+      start-lab)))
 
 \f
 ;;;; PSEUDO-ATOMIC
@@ -548,26 +573,30 @@
         (move result value)))))
 
 ;;; helper for alien stuff.
+
 (def!macro with-pinned-objects ((&rest objects) &body body)
   "Arrange with the garbage collector that the pages occupied by
-OBJECTS will not be moved in memory for the duration of BODY. Useful
-for e.g. foreign calls where another thread may trigger garbage
-collection"
+OBJECTS will not be moved in memory for the duration of BODY.
+Useful for e.g. foreign calls where another thread may trigger
+collection."
   (if objects
-      `(multiple-value-prog1
-           (progn
-             ,@(loop for p in objects
-                     collect
-                     ;; There is no race here wrt to gc, because at every
-                     ;; point during the execution there is a reference to
-                     ;; P on the stack or in a register.
-                        `(push-word-on-c-stack
-                          (int-sap (sb!kernel:get-lisp-obj-address ,p))))
-             ,@body)
-         ;; If the body returned normally, we should restore the stack pointer
-         ;; for the benefit of any following code in the same function.  If
-         ;; there's a non-local exit in the body, sp is garbage anyway and
-         ;; will get set appropriately from {a, the} frame pointer before it's
-         ;; next needed
-         (pop-words-from-c-stack ,(length objects)))
+      (let ((pins (make-gensym-list (length objects)))
+            (wpo (block-gensym "WPO")))
+        ;; BODY is stuffed in a function to preserve the lexical
+        ;; environment.
+        `(flet ((,wpo () (progn ,@body)))
+           ;; PINS are dx-allocated in case the compiler for some
+           ;; unfathomable reason decides to allocate value-cells
+           ;; for them -- since we have DX value-cells on x86oid
+           ;; platforms this still forces them on the stack.
+           (dx-let ,(mapcar #'list pins objects)
+             (multiple-value-prog1 (,wpo)
+               ;; TOUCH-OBJECT has a VOP with an empty body: compiler
+               ;; thinks we're using the argument and doesn't flush
+               ;; the variable, but we don't have to pay any extra
+               ;; beyond that -- and MULTIPLE-VALUE-PROG1 keeps them
+               ;; live till the body has finished. *whew*
+               ,@(mapcar (lambda (pin)
+                           `(touch-object ,pin))
+                         pins)))))
       `(progn ,@body)))