;;;; suspension.scm


(module suspension (with-limited-continuation 
		    continuation-drop
		    continuation-suspend
		    continuation-resume) 
  (import scheme chicken ports foreign)

(use srfi-18 s11n)

(declare (disable-interrupts))

(define error-output ##sys#standard-error)
(define standard-output ##sys#standard-output)
(define standard-input ##sys#standard-input)

(define (exception-handler ex)
  (thread-signal! (thread-specific ##sys#current-thread) ex)
  (continuation-drop #f) )

(define (with-limited-continuation thunk)
  (let* ((t (make-thread 
	     (lambda ()
	       (##sys#call-with-cthulhu
		(lambda () 
		  (##sys#call-with-values thunk continuation-drop) ) ) ) ) )
	 (state (##sys#slot t 5)) )
    (##sys#setislot state 0 '())
    (##sys#setslot state 1 standard-input)
    (##sys#setslot state 2 standard-output)
    (##sys#setslot state 3 error-output) 
    (##sys#setslot state 4 exception-handler)
    (thread-specific-set! t ##sys#current-thread)
    (thread-start! t)
    (thread-suspend! ##sys#current-thread)
    (##sys#setslot (##sys#slot t 5) 5 (##sys#slot state 5))
    (##sys#apply-values (##sys#slot t 2)) ) )

(define (continuation-drop . results)
  (##sys#setslot ##sys#current-thread 2 results)
  (thread-resume! (thread-specific ##sys#current-thread))
  (##sys#thread-kill! ##sys#current-thread 'dead) 
  (##sys#schedule) )

(define (continuation-suspend store)
  (##sys#apply-values
   (##sys#call-with-direct-continuation
    (lambda (k)
      (let ((o (open-output-string)))
	(serialize k o)
	(##sys#call-with-values 
	 (lambda () (store (get-output-string o)))
	 continuation-drop) ) ) ) ) )

(define direct-return
  (foreign-lambda* void ((scheme-object dk) (scheme-object x))
    "C_kontinue(dk, x);"))

(define (continuation-resume k . results)
  (direct-return (with-input-from-string k deserialize) results) )

)