X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fmacros.lisp;h=03da6d7df6a87881aedb28d954788bc12530d5d8;hb=b9519773faa7b3c98915eccb9cb1fd8a8270ee56;hp=6c53ab48288d3382a6290ffa391ec30f2d1ed57c;hpb=dee739730210c96a20c15a3e08c831c9615ac95f;p=sbcl.git diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp index 6c53ab4..03da6d7 100644 --- a/src/compiler/x86-64/macros.lisp +++ b/src/compiler/x86-64/macros.lisp @@ -138,30 +138,31 @@ ;;; node-var then it is used to make an appropriate speed vs size ;;; decision. -(defun allocation-dynamic-extent (alloc-tn size) +(defun allocation-dynamic-extent (alloc-tn size lowtag) (inst sub rsp-tn size) ;; see comment in x86/macros.lisp implementation of this (inst and rsp-tn #.(lognot lowtag-mask)) (aver (not (location= alloc-tn rsp-tn))) - (inst mov alloc-tn rsp-tn) + (inst lea alloc-tn (make-ea :byte :base rsp-tn :disp lowtag)) (values)) ;;; This macro should only be used inside a pseudo-atomic section, ;;; which should also cover subsequent initialization of the ;;; object. -(defun allocation-tramp (alloc-tn size &optional ignored) - (declare (ignore ignored)) +(defun allocation-tramp (alloc-tn size lowtag) (inst push size) (inst lea temp-reg-tn (make-ea :qword :disp (make-fixup "alloc_tramp" :foreign))) (inst call temp-reg-tn) (inst pop alloc-tn) + (when lowtag + (inst lea alloc-tn (make-ea :byte :base alloc-tn :disp lowtag))) (values)) -(defun allocation (alloc-tn size &optional ignored dynamic-extent) +(defun allocation (alloc-tn size &optional ignored dynamic-extent lowtag) (declare (ignore ignored)) (when dynamic-extent - (allocation-dynamic-extent alloc-tn size) + (allocation-dynamic-extent alloc-tn size lowtag) (return-from allocation (values))) (let ((NOT-INLINE (gen-label)) (DONE (gen-label)) @@ -188,7 +189,7 @@ :scale 1 :disp (make-fixup "boxed_region" :foreign 8)))) (cond (in-elsewhere - (allocation-tramp alloc-tn size)) + (allocation-tramp alloc-tn size lowtag)) (t (inst mov temp-reg-tn free-pointer) (if (tn-p size) @@ -201,17 +202,19 @@ (inst cmp end-addr alloc-tn) (inst jmp :be NOT-INLINE) (inst mov free-pointer alloc-tn) - (inst mov alloc-tn temp-reg-tn) + (if lowtag + (inst lea alloc-tn (make-ea :byte :base temp-reg-tn :disp lowtag)) + (inst mov alloc-tn temp-reg-tn)) (emit-label DONE) (assemble (*elsewhere*) (emit-label NOT-INLINE) (cond ((numberp size) - (allocation-tramp alloc-tn size)) + (allocation-tramp alloc-tn size lowtag)) (t (inst sub alloc-tn free-pointer) - (allocation-tramp alloc-tn alloc-tn))) - (inst jmp DONE)) - (values))))) + (allocation-tramp alloc-tn alloc-tn lowtag))) + (inst jmp DONE)))) + (values))) ;;; Allocate an other-pointer object of fixed SIZE with a single word ;;; header having the specified WIDETAG value. The result is placed in @@ -222,63 +225,55 @@ (bug "empty &body in WITH-FIXED-ALLOCATION")) (once-only ((result-tn result-tn) (size size) (stack-allocate-p stack-allocate-p)) `(maybe-pseudo-atomic ,stack-allocate-p - (allocation ,result-tn (pad-data-block ,size) ,inline ,stack-allocate-p) + (allocation ,result-tn (pad-data-block ,size) ,inline ,stack-allocate-p + other-pointer-lowtag) (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag) - ,result-tn) - (inst lea ,result-tn - (make-ea :qword :base ,result-tn :disp other-pointer-lowtag)) + ,result-tn 0 other-pointer-lowtag) ,@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 - ;; 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. Do the same on x86-64 as we do on x86 until this gets - ;; sorted out. - #!+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 + ;; 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. Do the same on x86-64 as we do on x86 until this gets + ;; sorted out. + #!+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) ; eg 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) + (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))) @@ -290,9 +285,8 @@ ;;; place and there's no logical single place to attach documentation. ;;; grep (mostly in src/runtime) is your friend -;;; FIXME: THIS NAME IS BACKWARDS! -(defmacro maybe-pseudo-atomic (really-p &body body) - `(if ,really-p +(defmacro maybe-pseudo-atomic (not-really-p &body body) + `(if ,not-really-p (progn ,@body) (pseudo-atomic ,@body))) @@ -362,11 +356,9 @@ (:result-types ,el-type) (:generator 5 (move rax old-value) - #!+sb-thread - (inst lock) (inst cmpxchg (make-ea :qword :base object :index index :disp (- (* ,offset n-word-bytes) ,lowtag)) - new-value) + new-value :lock) (move value rax))))) (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)