/usr/share/scheme48-1.9/big/callback.scm

; Part of Scheme 48 1.9.  See file COPYING for notices and license.

; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber, Marcus Crestani, Robert Ransom,
; Harald Glab-Phlak


; This code, along with C code in c/external.c, handles the interaction between
; callbacks from external code to Scheme functions and uses of continuations in
; Scheme.  The problem is that Scheme 48 uses multiple continuations while
; operating with only one process stack.
;
; Suppose we have Scheme procedures s1 and s2 and C procedure c1 such that
; s1 calls c1 and c1 calls s2.  There are two trampoline functions that are
; used to do this.  The VM uses s48_external_call to call c1 and c1 uses
; s48_call_scheme to start the VM running s2.  While in s2 the process stack will
; look like this:
;
;  <C frame for VM running s2>
;  <C frame for s48_call_scheme>
;  <C frame for c1>
;  <C frame for s48_external_call>
;  <C frame for VM running s1>
;  <base>
;
; The C code in c/external.scm keeps a record of the portions of the process
; stack that are running external code.  Each of these stack portions has an
; s48_external_call frame at the base and an s48_call_scheme frame at the top.
; The stack is represented as linked list of records, called `stack-block's,
; each of which contains the following values:
;    free?       ; true if this frame is no longer needed
;    unwind      ; the longjmp target used to skip over this frame
;    proc-name   ; the name of the procedure this block is executing
;    placeholder ; either #f or a placeholder, see the section on threads below
;    next        ; the next stack-block below this one
; These are Scheme records and are traced by the GC.

(define-record-type stack-block :stack-block
  (stack-blocks-are-made-from-c)
  stack-block?
  (free? stack-block-free? set-stack-block-free?!)
  (unwind stack-block-unwind)
  (proc-name stack-block-proc-name)
  (placeholder stack-block-placeholder set-stack-block-placeholder!)
  (next stack-block-next))

; Stack-blocks are made from C, so we need to export the type.

(define-exported-binding "s48-stack-block-type" :stack-block)

; There is no need to keep track of the VM frames.  These are all interchangeable
; because 1) the VM's state is kept in top-level variables and 2) we have
; arranged it so that the relevant VM opcodes, call-external-value and
; return-from-callback, are all the same length and are always immediately
; followed by a return instruction.  s48_call_scheme can safely overwrite the
; template and code-pointer registers in the VM as they always point to a
; one-byte instruction followed by a return instruction.  When the VM returns
; from the callback, via a return-from-callback instruction, that too is a
; one-byte instruction followed by a return instruction.  The VM can proceed,
; happily ignorant of all this fooling around.
;
; On entry, s48_external_call saves a longjump target.  This is used when
; raising exceptions from with the external code and for unwinding the process
; stack.  Each invocation of s48_call_scheme creates a new stack-block, saving
; within it the longjump target of the corresponding s48_external_call.  `Free?'
; and `placeholder' are initially false and `next' points to existing list of
; stack-blocks.
;
; When a callback returns to s48_call_scheme, the corresponding block is popped
; off the list of stack-blocks.
;
; So far so good, and if that were all that happened there would be no need for
; all this mechanism.  There are two problems: call/cc and threads.  Call/cc is
; simpler to deal with.  We have downward continuations in C, as implemented
; by longjmp(), so we simply limit continuations that cross callbacks to being
; downwards only.  We also need to arrange for any jumped-over stack portions
; to be popped off of the stack.
;
; The popping off is handled by s48_external_call.  Just before returning to the
; VM it checks to see if the top stack-block is free.  If so, it loops through
; the list of stack-blocks to find the first non-free stack portion.  A longjump
; is performed to the target in the last free block, removing any unneeded frames
; from the stack.
;
; s48_call_scheme starts the VM running the following CALLBACK procedure.  The
; arguments are BLOCK, the stack-block just created for this callback, and
; the procedure and arguments for the actual callback.  It prevents jumps back
; into the callback and frees BLOCK if a throw out occurs.
;
; We disable interrupts to ensure that nothing intervenes between setting DONE?
; and returning from the callback.  BLOCK is then either freed or returned to,
; but not both or neither.  RETURN-FROM-CALLBACK reenables interrupts.

(define (callback block proc . args)
  (let ((done? #f))
    (return-from-callback block
			  (dynamic-wind
			   (lambda ()
			     (if done?
				 (apply
				  assertion-violation 'callback
				  "attempt to throw into a callback"
				  (cons proc args))))
			   (lambda ()
			     (let ((result (apply proc args)))
			       (disable-interrupts!)
			       (set! done? #t)
			       result))
			   (lambda ()
			     (if (not done?)
				 (begin
				   (set! done? #t)
				   (set-stack-block-free?! block #t)
				   (clear-stack-top!))))))))

(define-exported-binding "s48-callback" callback)

; CLEAR-STACK-TOP! is an empty C procedure.  When it returns, s48_external_call
; will automatically clear any free frames off of the stack.

(import-lambda-definition clear-stack-top! () "s48_clear_stack_top")

; Dealing with threads.
;
; The difficulty here is that each stack-block belongs to some thread.  Thread A
; can call a C procedure which calls back into Scheme.  At that point a context
; switch occurs and we start running thread B, which promptly does the same
; calls.  The process stack then looks like this:
; 
;  <C frame for VM running B1>
;  <C frame for s48_call_scheme>
;  <C frame for B's C code>
;  <C frame for s48_external_call>
;  <C frame for VM running A1 and then B0>
;  <C frame for s48_call_scheme>
;  <C frame for A's C code>
;  <C frame for s48_external_call>
;  <C frame for VM running A0>
;  <base>
;
; At this point A cannot return from its callback before B does, because B's
; portion of the process stack is above A's.  If A does try to return it must
; block until it again is at the top of the stack.
;
; This is handled by s48_call_scheme, which checks to see if the stack-block
; being returned to is at the top of the stack.  If not, it does a second
; callback to DELAY-CALLBACK-RETURN, defined below, with the same stack-block.
; DELAY-CALLBACK-RETURN creates a placeholder, puts it in the stack-block, and
; then blocks on it.  When the placeholder gets a value the procedure attempts
; another return-from-callback.
;
; This is called with interrupts disabled, as we need to avoid having BLOCK
; reach the top of the stack before the placeholder is installed.

(define (delay-callback-return block value)
  (let ((placeholder (make-placeholder)))
    (set-stack-block-placeholder! block placeholder)
    (enable-interrupts!)
    (placeholder-value placeholder)
    value))

(define-exported-binding "s48-delay-callback-return" delay-callback-return)

; Finally, s48_external_call looks to see if the top stack-block has a
; placeholder.  If it does, it raises an exception instead of doing a normal
; return.  The exception handler sets the placeholder's value, allowing the
; blocked thread to continue.  The handler then returns the external call's
; value to its own thread, or, if the callback-return-uncovered is piggybacked
; on another exception, we raise that exception.
;
; Because of the all of the games played above, the callback-return-uncovered
; exception may appear to have come from either the call-external-value, or
; return-from-callback opcodes.

(define uncovered-return-handler
  (lambda (opcode reason . args)

    (define (blow-up con extract-message)
      ;; look at external.c for why this is all so strangely reversed
      (let ((rev (reverse args)))
	(raise
	 (condition
	 con
	 (make-external-exception)
	 (make-who-condition (cadr rev))
	 (make-message-condition
	  (os-string->string (byte-vector->os-string (extract-message (car rev)))))
	 (make-irritants-condition (reverse (cddr rev)))))))

    (enum-case exception reason
	       ((external-error)
		(blow-up (make-error) values))
	       ((external-assertion-violation)
		(blow-up (make-assertion-violation) values))
	       ((external-os-error)
		(blow-up (make-error) os-error-message))
	       ((out-of-memory)
		(raise
		 (condition
		  (make-implementation-restriction-violation)
		  (make-who-condition 'call-external-value)
		  (make-message-condition "out of memory"))))
	       ((callback-return-uncovered)
		(call-with-values
		    (lambda ()
		      (if (= 2 (length args))
			  (values (car args)
				  (cadr args)
				  #f)
			  (let ((args (reverse args)))
			    (values (car args)
				    (cadr args)
				    (reverse (cddr args))))))
		  (lambda (block return-value exception-args)
		    (let ((placeholder (stack-block-placeholder block)))
		      (set-stack-block-placeholder! block #f)
		      (placeholder-set! placeholder #t)
		      (if exception-args
			  (apply signal-vm-exception opcode return-value exception-args)
			  return-value)))))
	       (else
		(apply signal-vm-exception opcode reason args)))))

(define-condition-type &external-exception &serious
  make-external-exception external-exception?)

(define (block-depth block)
  (if block
      (+ 1 (block-depth (stack-block-next block)))
      0))

(for-each (lambda (opcode)
	    (define-vm-exception-handler opcode uncovered-return-handler))
	  (list (enum op call-external-value)
		(enum op return-from-callback)))

;----------------
; Utility for the common case of calling an imported binding.

(define (call-imported-binding proc . args)
  (if (and (shared-binding? proc)
	   (shared-binding-is-import? proc))
      (let ((value (shared-binding-ref proc)))
	(if (byte-vector? value)
	    (apply call-external-value
		   value
		   (shared-binding-name proc)
		   args)
	    (apply assertion-violation 'call-imported-binding "bad procedure"
		   proc args)))
      (apply assertion-violation 'call-imported-binding "procedure not defined"
	     proc args)))

(define (call-imported-binding-2 proc . args)
  (if (and (shared-binding? proc)
	   (shared-binding-is-import? proc))
      (let ((value (shared-binding-ref proc)))
	(if (byte-vector? value)
	    (apply call-external-value-2
		   value
		   (shared-binding-name proc)
		   args)
	    (apply assertion-violation 'call-imported-binding-2 "bad procedure"
		   proc args)))
      (apply assertion-violation 'call-imported-binding-2 "procedure not defined"
	     proc args)))

;----------------
; We export the record-type type so that external code can check to see if
; supposed record types really are such.

(define-exported-binding "s48-the-record-type" :record-type)

;----------------
; Testing
;
; `s48_trampoline' is a C routine that calls its Scheme argument with between
; zero and three arguments.  The arguments are 100, 200, and 300.
;
;(import-lambda-definition trampoline (proc nargs)
;                          "s48_trampoline")
;
;(define (foo . args)
;  (for-each display (list "[foo " args "]"))
;  (newline)
;  (cons 'foo-return args))
;
;; This should return 1100.
;
;(define (test0)
;  (trampoline (lambda ()
;                (call-with-current-continuation
;                  (lambda (c)
;                    (trampoline (lambda (x)
;                                  (c (+ x 1000)))
;                                1))))
;              0))
;
;; ,open threads locks debug-messages
;
;(define (test1 error?)
;  (let ((lock (make-lock))
;        (repl-lock (make-lock)))
;    (obtain-lock repl-lock)
;    (spawn (lambda ()
;             (obtain-lock lock)
;             (debug-message "A returned "
;                           (trampoline (lambda ()
;                                         (obtain-lock lock) ; we block
;                                         'a)
;                                       0))
;             (release-lock repl-lock))
;           'thread-a)
;    (spawn (lambda ()
;             (debug-message "B returned "
;                           (trampoline (lambda ()
;                                         (release-lock lock)    ; A can run
;                                         (relinquish-timeslice) ; let A run
;                                         (if error? #f 'b))
;                                       0)))
;           'thread-b)
;    (obtain-lock repl-lock)))
scheme48 1.9-5 / usr / share / scheme48-1.9 / big / callback.scm
