;;;
;;; ptrace-amd64.lisp
;;;
;;; Amd64 register access for ptrace processes.
;;;

(cl:in-package :lh-debug-core)


;;; Amd64 class for specialization.

(defclass amd64-ptrace-process (ptrace-process)
  (general-regs
   regs-valid
   regs-dirty))


;;; User register structure for ptrace.

(define-alien-type nil
    (struct amd64-user-regs-struct
	    (r15 unsigned-long)
	    (r14 unsigned-long)
	    (r13 unsigned-long)
	    (r12 unsigned-long)
	    (bp unsigned-long)
	    (bx unsigned-long)
	    (r11 unsigned-long)
	    (r10 unsigned-long)
	    (r9 unsigned-long)
	    (r8 unsigned-long)
	    (ax unsigned-long)
	    (cx unsigned-long)
	    (dx unsigned-long)
	    (si unsigned-long)
	    (di unsigned-long)
	    (orig_ax unsigned-long)
	    (ip unsigned-long)
	    (cs unsigned-long)
	    (flags unsigned-long)
	    (sp unsigned-long)
	    (ss unsigned-long)
	    (fs_base unsigned-long)
	    (gs_base unsigned-long)
	    (ds unsigned-long)
	    (es unsigned-long)
	    (fs unsigned-long)
	    (gs unsigned-long)))


;;; Register cache management.

;; FIXME: Dirty register flushing on resume and detach?

;; FIXME: Don't leak the alien struct?

(defmethod resume-process :before ((process amd64-ptrace-process)
				   &key &allow-other-keys)
  (setf (slot-value process 'regs-valid) nil))

(defun check-register-cache (process)
  (unless (slot-boundp process 'general-regs)
    (setf (slot-value process 'general-regs)
	  (make-alien (struct amd64-user-regs-struct)))
    (setf (slot-value process 'regs-valid) nil))

  (unless (slot-value process 'regs-valid)
    (with-slots (pid general-regs) process
      (multiple-value-bind
	    (result errno)
	  (ptrace ptrace-getregs pid nil general-regs)
	(unless (zerop result)
	  (error "Unable to read general registers for pid ~D: ~S"
		 pid (sb-int:strerror errno)))))
    (setf (slot-value process 'regs-valid) t)))


;;; Register access.

;; FIXME: Some of this feels like a generic interface.

(defgeneric register-value (process register-name))

(defgeneric (setf register-value) (value process register-name))

;; This DECLAIM FTYPE gives the compiler sufficient information to be
;; able to compile the two DEFMETHODs for REGISTER-VALUE accessors
;; below without WARNINGs, THE forms or the DECLARE NOTINLINEs that
;; you can see commented-out in the method bodies.
(declaim (ftype (function (symbol (alien (* (struct amd64-user-regs-struct))))
			  (values (alien (* unsigned-long)) &optional))
		find-amd64-register))
(defun find-amd64-register (register-name register-struct)
  (macrolet ((regslot (name)
	       `(addr (slot register-struct ',name))))
    (ecase register-name
      ;; FIXME: Do we need orig_ax or the segment registers and bases?
      (:orig-rax (regslot orig_ax))
      (:rax (regslot ax))
      (:rcx (regslot cx))
      (:rdx (regslot dx))
      (:rbx (regslot bx))
      (:rsp (regslot sp))
      (:rbp (regslot bp))
      (:rsi (regslot si))
      (:rdi (regslot di))
      (:r8 (regslot r8))
      (:r9 (regslot r9))
      (:r10 (regslot r10))
      (:r11 (regslot r11))
      (:r12 (regslot r12))
      (:r13 (regslot r13))
      (:r14 (regslot r14))
      (:r15 (regslot r15))
      
      (:rip (regslot ip))
      ;; FIXME: Is the next the right name?
      (:rflags (regslot flags)))))

(defmethod register-value ((process amd64-ptrace-process) register-name)
  ;; This DECLARE NOTINLINE shuts the compiler up.  There's a bug in
  ;; the compiler's handling of DEREF having to do with type inference
  ;; that is fixed by either a THE form around the call to
  ;; FIND-AMD64-REGISTER or the DECLAIM FTYPE earlier in this file.
  ;;(declare (notinline deref))
  (check-register-cache process)
  (deref (find-amd64-register register-name
			      (slot-value process 'general-regs))))

(defmethod (setf register-value)
    (value (process amd64-ptrace-process) register-name)
  ;; This declare notinline is worse than the one above, as it's a
  ;; bloody internals-package symbol.  Same logic, though.
  ;;(declare (notinline sb-alien-internals:%set-deref))
  (check-register-cache process)
  (setf (deref (find-amd64-register register-name
				    (slot-value process 'general-regs)))
	value)
  (setf (slot-value process 'regs-dirty) t)
  value)

;;; EOF
