X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fmacros.lisp;h=df6f8560c882443693cb5c677d8d4a939ac002ed;hb=9b1fade83db8453b75b8c7380eb12ce41b5b889c;hp=4c1fba68413d8239afb9796c16d7a08d88f00e4a;hpb=bbc19242c0683a6c8cb93146eab22e29aa453801;p=sbcl.git diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index 4c1fba6..df6f856 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -294,55 +294,49 @@ ,@forms))) ;;;; error code -(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) - (defun emit-error-break (vop kind code values) - (let ((vector (gensym))) - `((progn - #-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)) - ;; The return PC points here; note the location for the debugger. - (let ((vop ,vop)) - (when vop - (note-this-location vop :internal-error))) - (inst byte ,kind) ; eg trap_Xyyy - (with-adjustable-vector (,vector) ; interr arguments - (write-var-integer (error-number-or-lose ',code) ,vector) - ,@(mapcar (lambda (tn) - `(let ((tn ,tn)) - ;; classic CMU CL comment: - ;; zzzzz jrd here. tn-offset is zero for constant - ;; tns. - (write-var-integer (make-sc-offset (sc-number - (tn-sc tn)) - (or (tn-offset tn) - 0)) - ,vector))) - values) - (inst byte (length ,vector)) - (dotimes (i (length ,vector)) - (inst byte (aref ,vector i)))))))) - -(defmacro error-call (vop error-code &rest values) +(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) + ;; The return PC points here; note the location for the debugger. + (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) + ;; classic CMU CL comment: + ;; zzzzz jrd here. tn-offset is zero for constant + ;; tns. + (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)))))) + +(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))) ;;;; PSEUDO-ATOMIC @@ -357,8 +351,8 @@ ;;; does not matter whether a signal occurs during construction of a ;;; dynamic-extent object, as the half-finished construction of the ;;; object will not cause any difficulty. We can therefore elide -(defmacro maybe-pseudo-atomic (really-p &body forms) - `(if ,really-p +(defmacro maybe-pseudo-atomic (not-really-p &body forms) + `(if ,not-really-p (progn ,@forms) (pseudo-atomic ,@forms))) @@ -548,26 +542,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)))