;;;
;;; ptrace-process.lisp
;;;
;;; Ptrace(2) interface to process abstraction.
;;;

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


;;; Extra stuff for processes that can be ptraced.

(defclass ptrace-process (process)
  ((pid :initarg :pid)))

(defparameter *default-process-class* 'amd64-ptrace-process)


;;; Extra stuff for dealing with ptrace(2).

;; The DATA argument to ptrace(2) is declared as a void *, or to us,
;; an (* t).  It is then treated as if it were an appropriate place to
;; accept -integer- arguments.  Hence, this mess:

(declaim (inline integer-ptrace-data))
(defun integer-ptrace-data (data)
  (sap-alien (sb-sys:int-sap data) (* t)))


;;; Getting a debuggable process.

;; There are two ways to get a new process.  Either fork/traceme/exec
;; or attach.  The only one we've tried so far is attach, so we'll set
;; that up first.

;; FIXME: This interface is somewhat broken.  Perhaps what we need is
;; a wrapper that allows for passing arbitrary arguments, including a
;; notion of process identity to make-instance, and then calling a
;; generic function to do the actual attachment, which would allow for
;; attaching to a debug slave with just a slight variation in process
;; identity and a different class.

(defun attach-to-process (pid)
  ;; FIXME: Add some way to specify a subclass of PROCESS and to
  ;; supply additional initargs for MAKE-INSTANCE.
  (multiple-value-bind
	(failure errno)
      (ptrace ptrace-attach pid nil nil)
    (if (zerop failure)
 	(let ((process (make-instance *default-process-class* :pid pid)))
	  (multiple-value-bind
		(failure errno)
	      (ptrace ptrace-setoptions pid nil
		      (integer-ptrace-data ptrace-o-mask))
	    (unless (zerop failure)
	      (warn "Failed to set ptrace options for pid ~D: ~S"
		    pid (sb-int:strerror errno))))
	  (setf (slot-value process 'status) :attaching)
	  (call-event-function process :attaching)
	  process)
	(error "Failed to attach to pid ~D: ~S"
	       pid (sb-int:strerror errno)))))


;;; Event handling.

;; The intent here is that either update-process-status will be called
;; from serve-event after SIGCHLD has been recieved via a signalfd, or
;; it will be called in a loop in some manner.  As such, none of the
;; interface functions such as resume-process call
;; update-process-status, thus avoiding the direct chance of unbounded
;; recursion by calling them from within an event-function.

(defmethod update-process-status ((process ptrace-process) &key (wait nil))
  (with-slots (pid status) process
    (when (member status '(:detached :exited :killed))
      (error "Attempted to update status of ~S process with pid ~D"
	     status pid))
    (multiple-value-bind
	  (wait-pid wait-status errno)
	(waitpid pid (if wait 0 wnohang))
      (cond
	((zerop wait-pid)
	 ;; Status unchanged
	 )
	((not (zerop errno))
	 ;; Something went wrong
	 (error "Failed to update process status for pid ~D: ~S"
		pid (sb-int:strerror errno)))
	((not (= wait-pid pid))
	 ;; WTF?
	 (error "Got pid ~D from waitpid on pid ~D" wait-pid pid))
	(t
	 ;; FIXME: This is the primary event interface.  We should
	 ;; have some real event-handling mechanism here, not just
	 ;; reporting the events to *standard-output*.
	 (cond
	   ((wifexited wait-status)
	    #+(or)
	    (format t "Process ~D exited with signal ~D.~%"
		    pid (wexitstatus wait-status))
	    (setf status :exited)
	    (call-event-function process :exited (wexitstatus wait-status)))

	   ((wifsignaled wait-status)
	    #+(or)
	    (format t "Process ~D killed with signal ~D (core ~S dumped).~%"
		    pid (wtermsig wait-status) (wcoredump wait-status))
	    (setf status :killed)
	    (call-event-function process :killed
				 (wtermsig wait-status) (wcoredump wait-status)))

	   ((wifstopped wait-status)
	    (let ((stop-signal (wstopsig wait-status))
		  ;; KLUDGE: There is no C macro that I was able to
		  ;; find mentioned in the documentation for reading
		  ;; the event code, but this is where it lives.
		  (event-code (ldb (byte 8 16) wait-status)))
	      (setf status :stopped)
	      (cond
		((= stop-signal (logior #x80 sb-posix:sigtrap))
		 #+(or)
		 (format t "Process ~D stopped prior to syscall.~%" pid)
		 (call-event-function process :syscall))
		((and (= stop-signal sb-posix:sigtrap)
		      (not (zerop event-code)))
		 #+(or)
		 (format t "Process ~D stopped with event ~D.~%"
			 pid event-code)
		 (call-event-function process :event event-code))
		(t
		 #+(or)
		 (format t "Process ~D stopped with signal ~D.~%"
			 pid stop-signal)
		 (call-event-function process :stopped stop-signal)))))

	   ((wifcontinued wait-status)
	    ;; Not sure if this ever actually happens.
	    (setf status :running)
	    (call-event-function process :running))

	   (t
	    (error "Unknown wait status #x~X for pid ~D" wait-status pid))))))))


;;; Detachment.

(defmethod detach-from-process ((process ptrace-process)
				&optional (signal-number 0))
  ;; FIXME: Don't bother detaching from a dead or already-detached
  ;; process.
  ;; FIXME: Error handling?
  (ptrace ptrace-detach (slot-value process 'pid) nil
	  (sap-alien (sb-sys:int-sap signal-number) (* t)))
  (setf (slot-value process 'status) :detached)
  (call-event-function process :detached))


;;; Resumption.

(defmethod resume-process ((process ptrace-process)
			   &key (send-signal 0) (resume-mode :normal))
  ;; FIXME: Error handling?
  (let ((request (ecase resume-mode
		   (:normal ptrace-cont)
		   (:until-syscall ptrace-syscall)
		   (:singlestep ptrace-singlestep))))
    (ptrace request (slot-value process 'pid) nil
	    (sap-alien (sb-sys:int-sap send-signal) (* t))))
  (setf (slot-value process 'status) :running)
  (call-event-function process :running))


;;; EOF
