;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;;;; Forking

(in-package :philip-jose)

#-sbcl
(progn
  (defvar *expected-children 2.1)
  (defvar *expected-space* 16000000))

#+sbcl
(progn
  ;; Simple heuristic: if we have allocated more than the given ratio
  ;; of what is allowed between GCs, then trigger the GC.
  ;; note: can possibly modify parameters and reset in sb-ext:*after-gc-hooks*
  (defparameter *prefork-allocation-reserve-ratio* .10) ; default ratio: 10%
  (defun should-i-gc-p ()
    (let ((available-bytes (- (sb-alien:extern-alien "auto_gc_trigger" sb-alien:long)
                              (sb-kernel:dynamic-usage)))
          (allocation-threshhold (sb-ext:bytes-consed-between-gcs)))
      (< available-bytes (* *prefork-allocation-reserve-ratio* allocation-threshhold)))))

(defun pre-fork-hook ()
  #+sbcl
  (when (should-i-gc-p)
    (sb-ext:gc))
  nil)

(defun do-fork ()
  #-sbcl (et:fork)
  #+sbcl (sb-posix:fork))

(defun post-fork-child-cleanup ()
  nil)

(defun post-fork-parent-hook (pid)
  pid)

(defun fork ()
  (pre-fork-hook)
  (let ((pid (do-fork)))
    (if (zerop pid)
        (post-fork-child-cleanup)
        (post-fork-parent-hook pid))
    pid))


(defvar *cleanup-pusher* nil
  "dynamically-scoped function for declaring cleanups")
(defun push-cleanup (cleanup)
  (if *cleanup-pusher*
      (funcall *cleanup-pusher* cleanup)
      (error "No cleanup pusher declared")))
(defun call-with-cleanups (thunk)
  (let ((cleanups nil))
    (flet ((push-cleanup (cleanup) (push cleanup cleanups)))
      (unwind-protect
	   (funcall thunk #'push-cleanup)
	(dolist (cleanup cleanups)
	  (funcall cleanup))))))
(defun

(defun call-with-foreign-temporaries (thunk)
  (let (temporaries)
    (flet ((alloc (s)
	     (push s temporaries)))
      (unwind-protect
	   (funcall thunk alloc)
	(loop for s in temporaries do
	      (apply #'cffi:free-converted-object s)))))))

(defmacro with-foreign-temporaries (&body body)
  (with-gensyms (s)
    `(call-with-foreign-temporaries
      (lambda (,s)
	(macrolet ()
	  ,@body)))))

(cffi:defcenum frobork-kode
  :return
  :execve
  :dup2
  :close
  :fchdir
  :setuid
  :setgid
  :signal
  :setsid
  :setpgid
  :tcsetpgrp)

(cffi:defcfun (c-frobork "frobork") :int (kode :pointer))

(defun frobork-convert (v)
  (typecase v
    (integer
     v)
    (keyword
     
    (string
     (cffi:convert-to-foreign v :string))
    (integer
     v)



(defun frobork (kl)
  (let ((l (length kl)))
    (with-foreign-object (kode :int (1+ l))
      (let ((alloc-state
	     (loop with converted = nil
		   with state = nil
		   for i below l
		   for v in kl
		   do (multiple-value-setq (converted state)
			(frobork-convert v))
		   (setf (mem-aref kode :int i) converted)
		   when state
		   collect state)))
	(setf (mem-aref kode :int l) 0)
	(prog1
	    (c-frobork kode)
	  (loop for s in alloc-state
		do (apply #'cffi:free-converted-object s)))))))