/usr/share/scsh-0.6/big/callback.scm is in scsh-common-0.6 0.6.7-8.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 | ; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; 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 interchangable
; because 1) the VM's state is kept in top-level variables and 2) we have
; arranged it so that the relevent 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?
(error "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 procedures 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)
(if (= reason (enum exception 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-exception opcode return-value exception-args)
return-value))))
(apply signal-exception opcode reason args))))
(define (block-depth block)
(if block
(+ 1 (block-depth (stack-block-next block)))
0))
(for-each (lambda (opcode)
(define-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 call-error "bad procedure" call-imported-binding proc args)))
(apply call-error "bad procedure" call-imported-binding proc args)))
;----------------
; Helper functions for converting between C longs and Scheme bignums.
;
; HIGH and LOW are the two sixteen-bit halves of the negative magnitude of
; the number. The negative magnitude is used to avoid problems with two's
; complement's asymmetry.
(define (long-to-bignum positive? high low)
(let ((magnitude (+ (arithmetic-shift high 16)
low)))
(if positive?
(- magnitude)
magnitude)))
; Same again, except that we break the number into the sign and the two halves.
(define (bignum-to-long n)
(if (integer? n)
(let ((m (abs n)))
(vector (>= n 0)
(arithmetic-shift m -16)
(bitwise-and m sixteen-candles)))
#f))
(define sixteen-candles (- (arithmetic-shift 1 16) 1))
(define-exported-binding "s48-long-to-bignum" long-to-bignum)
(define-exported-binding "s48-bignum-to-long" bignum-to-long)
;----------------
; 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)))
|