(in-package "SB-VM") (declaim (inline stack-frame-return-offset (setf stack-frame-return-offset))) (defstruct stack-frame component (return-offset 0 :type (unsigned-byte 64)) size boxed unboxed) (defun process-tn-info (save-set ltns 2block) (let ((saved-tns '())) (flet ((save-tn (tn) (unless (and (eq (sc-sb (tn-sc tn)) (sb-or-lose 'stack)) (<= (tn-offset tn) 1)) (push (if (eq (sc-sb (tn-sc tn)) (sb-or-lose 'stack)) tn (or (sb-c::tn-save-tn tn) (error "Live TN must be on stack ~ or have a SAVE-TN"))) saved-tns)))) (map nil (lambda (savep ltn) (unless (or (zerop savep) (not (tn-p ltn))) (save-tn ltn))) save-set ltns) (do ((conflict (sb-c::ir2-block-global-tns 2block) (sb-c::global-conflicts-next-blockwise conflict))) ((null conflict)) (when (eq (sb-c::global-conflicts-kind conflict) :live) (save-tn (sb-c::global-conflicts-tn conflict))))) (let ((bitmap 0)) (dolist (tn saved-tns (values (sb-allocated-size 'stack) bitmap)) (when (eq (tn-sc tn) (sc-or-lose 'control-stack)) (setf bitmap (logior bitmap (ash 1 (tn-offset tn))))))))) (defun save-stack (address old-bp stack-frame) (declare (type fixnum address old-bp) (type stack-frame stack-frame) (optimize speed)) (let* ((address (get-lisp-obj-address address)) (sap (sb-sys:int-sap address)) (offset (sb-sys:sap-ref-word sap 0)) (stack-size (sb-sys:sap-ref-word sap 8)) (bitmap (sb-sys:sap-ref-word sap 16)) (stack-sap (sb-sys:int-sap (get-lisp-obj-address old-bp)))) (declare ((unsigned-byte 64) offset)) #+nil(format t "@~X stack-size: ~A save: ~2r~%" (sb-sys:sap-int stack-sap) stack-size bitmap) (when (> stack-size 64) (error "Can't handle more than 64 locals!")) (when (zerop offset) (format t "Computing offset~%") (let* ((component-addr (sb-sys:sap-int (sb-di::component-ptr-from-pc sap))) (diff (the (unsigned-byte 64) (- address component-addr)))) (setf offset diff (sb-sys:sap-ref-word sap 0) diff))) (let ((boxed (stack-frame-boxed stack-frame)) (unboxed (stack-frame-unboxed stack-frame)) (bitmap bitmap)) (declare ((unsigned-byte 64) bitmap)) (if (and (typep boxed '(simple-array t 1)) (>= (length boxed) stack-size)) (fill boxed 0) (setf boxed (make-array stack-size :initial-element 0))) (unless (and (typep unboxed '(simple-array (unsigned-byte 64) 1)) (>= (length unboxed) stack-size)) (setf unboxed (make-array stack-size :element-type '(unsigned-byte 64)))) (dotimes (i stack-size) (when (logbitp 0 bitmap) (setf (aref boxed i) (%make-lisp-obj (sb-sys:sap-ref-word stack-sap (* -8 (1+ i)))))) (when (zerop (setf bitmap (ash bitmap -1))) (return))) (sb-kernel:copy-ub64-from-system-area (sb-sys:int-sap (- (sb-sys:sap-int stack-sap) (* 8 stack-size))) 0 unboxed 0 stack-size) (setf (stack-frame-component stack-frame) (sb-di::component-from-component-ptr (sb-sys:int-sap (- address offset))) (stack-frame-return-offset stack-frame) (mod (+ offset (* 3 n-word-bytes)) (ash 1 64)) (stack-frame-size stack-frame) stack-size (stack-frame-boxed stack-frame) boxed (stack-frame-unboxed stack-frame) unboxed)))) (define-instruction qword (segment qword) (:emitter (emit-qword segment qword))) (defknown %restore-frame ((unsigned-byte 64) (and unsigned-byte fixnum) (simple-array t 1) (simple-array (unsigned-byte 64) 1)) *) (define-vop (%restore-frame) (:translate %restore-frame) (:policy :fast-safe) (:args (new-ip :scs (unsigned-reg)) (stack-size :scs (any-reg)) (boxed :scs (descriptor-reg)) (unboxed :scs (descriptor-reg))) (:arg-types unsigned-num positive-fixnum t t) (:temporary (:sc unsigned-reg :offset rcx-offset) rcx) (:temporary (:sc unsigned-reg :offset rdi-offset) rdi) (:temporary (:sc unsigned-reg :offset rsi-offset) rsi) (:generator 0 (inst mov rsp-tn rbp-tn) (inst sub rsp-tn stack-size) (inst cld) (inst lea rcx (make-ea :qword :base stack-size :disp (fixnumize -2))) (move rdi rsp-tn) (inst lea rsi (make-ea :qword :base unboxed :disp (- (fixnumize vector-data-offset) other-pointer-lowtag))) (inst rep) (inst movs :byte) (let ((loop-beg (gen-label)) (loop-test (gen-label))) (inst mov rcx stack-size) (inst jmp loop-test) (emit-label loop-beg) (inst lea rdi (make-ea :qword :base rbp-tn :disp (fixnumize -1))) (inst sub rdi rcx) (inst mov rsi (make-ea :qword :base boxed :index rcx :disp (- (fixnumize vector-data-offset) other-pointer-lowtag))) (inst test rsi rsi) (inst jmp :z loop-test) (inst mov (make-ea :qword :base rdi) rsi) (emit-label loop-test) (inst sub rcx (fixnumize 1)) (inst jmp :nz loop-beg)) (inst jmp new-ip))) (declaim (notinline restore-frame)) (defun restore-frame (stack-frame) (declare (type stack-frame stack-frame) (optimize speed)) (let ((new-ip (mod (+ (logandc2 (get-lisp-obj-address (stack-frame-component stack-frame)) lowtag-mask) (stack-frame-return-offset stack-frame)) (ash 1 64))) (stack-size (stack-frame-size stack-frame)) (unboxed (stack-frame-unboxed stack-frame)) (boxed (stack-frame-boxed stack-frame))) (declare (type (unsigned-byte 64) new-ip) (type (and unsigned-byte fixnum) stack-size)) (%restore-frame new-ip stack-size boxed unboxed))) ;; FIXME: Issues with conditionals that can't be flushed: LVAR becomes NIL. (defknown %save-frame (fdefn stack-frame) boolean (unwind sb-c::important-result predicate always-translatable)) (define-vop (%save-frame) (:translate %save-frame) (:policy :fast-safe) (:args (fdefn :scs (descriptor-reg) :target rax) (stack-frame :scs (descriptor-reg) :target rsi)) (:arg-types t t) (:temporary (:sc unsigned-reg :offset rbx-offset) rbx) (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0)) rax) (:temporary (:sc unsigned-reg :offset rcx-offset) rcx) (:temporary (:sc unsigned-reg :offset rdx-offset) rdx) (:temporary (:sc unsigned-reg :offset rdi-offset) rdi) (:temporary (:sc unsigned-reg :offset rsi-offset :from (:argument 1)) rsi) (:conditional :z) (:vop-var vop) (:save-p t) (:generator 0 (let ((label (gen-label)) (end (gen-label))) (move rbx rsp-tn) (inst sub rsp-tn (fixnumize 3)) (inst lea rdx (make-fixup nil :code-object label)) (move rax fdefn) (move rdi rbp-tn) (move rsi stack-frame) (inst mov rcx (fixnumize 3)) (inst mov (make-ea :qword :base rbx :disp (fixnumize -1)) rbp-tn) (inst mov rbp-tn rbx) (inst call (make-ea :qword :base rax :disp 9)) (inst cmov :b rsp-tn rbx) (inst cmp rax rax) (assemble (*elsewhere*) (emit-alignment n-fixnum-tag-bits #x90) #+nil(loop repeat 8 do (inst qword 0)) (emit-label label) (inst qword 0) ;; offset from component (multiple-value-bind (stack-size saved-bitmap) (process-tn-info (sb-c::vop-save-set vop) (sb-c::ir2-block-local-tns (sb-c::vop-block vop)) (sb-c::vop-block vop)) (inst qword stack-size) (inst qword saved-bitmap)) (inst test rbp-tn rbp-tn) (inst jmp end)) (emit-label end)))) (declaim (inline save-frame)) (defun save-frame (frame) (declare (type stack-frame frame)) (%save-frame (load-time-value (fdefinition-object 'save-stack nil) t) frame))