217 lines
7.2 KiB
Scheme
217 lines
7.2 KiB
Scheme
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
|
|
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
|
|
|
; Calling C procedures.
|
|
|
|
; The arguments have been pushed on the stack after the procedure.
|
|
; *stack* = procedure name arg1 ... argN rest-list N+1 total-nargs
|
|
;
|
|
; The procedure must be an external binding whose value is a pointer-sized
|
|
; code-vector. If it is, we actually do the call.
|
|
|
|
(define-primitive call-external-value ()
|
|
(lambda ()
|
|
(let* ((nargs (extract-fixnum (pop)))
|
|
(stack-nargs (extract-fixnum (pop)))
|
|
(rest-list (pop)))
|
|
(if (< maximum-external-call-args
|
|
(- nargs 2)); ignore procedure & name
|
|
(raise-exception too-many-arguments-to-external-procedure
|
|
0
|
|
(stack-ref (- stack-nargs 1))
|
|
nargs)
|
|
(begin
|
|
(do ((rest-list rest-list (vm-cdr rest-list)))
|
|
((vm-eq? rest-list null))
|
|
(push (vm-car rest-list)))
|
|
(let ((proc (stack-ref (- nargs 1)))
|
|
(name (stack-ref (- nargs 2)))
|
|
(args (pointer-to-stack-arguments)))
|
|
; Push a header to keep the arguments from being scanned.
|
|
(push (make-header (enum stob vector)
|
|
(cells->bytes nargs)))
|
|
(if (and (vm-string? name)
|
|
(code-vector? proc)
|
|
(= (code-vector-length proc)
|
|
(cells->bytes 1)))
|
|
(let ((result (external-call proc name (- nargs 2) args)))
|
|
(cond (*external-exception?*
|
|
(set! *external-exception?* #f)
|
|
(goto raise *external-exception-nargs*))
|
|
(else
|
|
(goto continue-with-value result 0))))
|
|
(raise-exception wrong-type-argument 0 proc name))))))))
|
|
|
|
;----------------
|
|
; Raising exceptions from C.
|
|
|
|
; True if the C procedure is raising an exception instead of doing a normal
|
|
; return.
|
|
|
|
(define *external-exception?* #f)
|
|
|
|
; The number of arguments being passed to the exception handler.
|
|
|
|
(define *external-exception-nargs*)
|
|
|
|
; These are for exceptions raised by external code. They work pretty
|
|
; much in the same way as other VM instructions raise exceptions.
|
|
; Note that this doesn't actually perform the raise; it just sets
|
|
; *EXTERNAL-EXCEPTION?* to be true, so that the EXTERNAL-CALL procedure
|
|
; will do the raise.
|
|
;
|
|
; If you extend the maximum number of arguments, be sure to adjust the
|
|
; definition of STACK-SLACK in stack.scm. It needs to know the maximum
|
|
; number of values pushed by an exception handler, which is the number
|
|
; of arguments pushed here, plus the procedure.
|
|
|
|
(define (s48-setup-external-exception why nargs)
|
|
(push-exception-continuation! why 1) ; 1 = one-byte instruction
|
|
(if (< 10 nargs)
|
|
(error "too many arguments from external exception"))
|
|
(set! *external-exception-nargs* nargs)
|
|
(set! *external-exception?* #t))
|
|
|
|
; The external code needs to piggyback an exception on top of one already
|
|
; being raised. We increase the argument count and return the old exception.
|
|
|
|
(define (s48-resetup-external-exception new-why additional-nargs)
|
|
(let* ((old-nargs *external-exception-nargs*)
|
|
(old-why (stack-ref old-nargs)))
|
|
(stack-set! old-nargs (enter-fixnum new-why))
|
|
(set! *external-exception-nargs* (+ old-nargs additional-nargs))
|
|
old-why))
|
|
|
|
;----------------
|
|
; Two tables of shared bindings: those we import from the outside and those
|
|
; that we provide to the outside.
|
|
|
|
(define *imported-bindings*)
|
|
(define *exported-bindings*)
|
|
|
|
; When resuming a statically-linked image these tables are FALSE.
|
|
|
|
(define (install-shared-bindings!+gc imported-bindings exported-bindings)
|
|
(receive (key imported-bindings exported-bindings)
|
|
(ensure-space-saving-temps (* hash-table-size 2)
|
|
imported-bindings
|
|
exported-bindings)
|
|
(set! *imported-bindings*
|
|
(if (vm-eq? imported-bindings false)
|
|
(make-hash-table key)
|
|
imported-bindings))
|
|
(set! *exported-bindings*
|
|
(if (vm-eq? exported-bindings false)
|
|
(make-hash-table key)
|
|
exported-bindings))))
|
|
|
|
(define shared-binding-table-size
|
|
(* hash-table-size 2))
|
|
|
|
(add-gc-root!
|
|
(lambda ()
|
|
(set! *imported-bindings* (s48-trace-value *imported-bindings*))
|
|
(set! *exported-bindings* (s48-trace-value *exported-bindings*))))
|
|
|
|
; These next two procedure are used to write the bindings tables out in images.
|
|
|
|
(define (s48-exported-bindings)
|
|
*exported-bindings*)
|
|
|
|
; This returns a version of the import table that contains only those bindings
|
|
; that have been traced, and in which the values of the bindings are all set to
|
|
; UNASSIGNED-VALUE.
|
|
|
|
(define s48-cleaned-imported-bindings
|
|
(let ((cleaner (table-cleaner shared-binding-next set-shared-binding-next!))
|
|
(walker (table-walker shared-binding-next)))
|
|
(lambda ()
|
|
(let ((table (s48-trace-value *imported-bindings*)))
|
|
(cleaner table)
|
|
(walker (lambda (binding)
|
|
(shared-binding-set! binding unassigned-marker))
|
|
table)
|
|
table))))
|
|
|
|
; Imported bindings.
|
|
|
|
(define lookup-imported-binding
|
|
(let* ((maker (lambda (string next key)
|
|
(make-shared-binding string true unspecific-value next key)))
|
|
(lookup (table-searcher shared-binding-name
|
|
shared-binding-next
|
|
maker)))
|
|
(lambda (name key)
|
|
(lookup *imported-bindings* name key))))
|
|
|
|
; Exporting bindings.
|
|
|
|
(define lookup-exported-binding
|
|
(let* ((maker (lambda (string next key)
|
|
(make-shared-binding string false unspecific-value next key)))
|
|
(lookup (table-searcher shared-binding-name
|
|
shared-binding-next
|
|
maker)))
|
|
(lambda (name key)
|
|
(lookup *exported-bindings* name key))))
|
|
|
|
; Print warnings about all imported bindings which the external code
|
|
; has not yet defined.
|
|
|
|
(define s48-warn-about-undefined-imported-bindings
|
|
(let ((walker (table-walker shared-binding-next)))
|
|
(lambda ()
|
|
(let ((out (current-error-port)))
|
|
(walker (lambda (binding)
|
|
(if (undefined? (shared-binding-ref binding))
|
|
(let ((name (shared-binding-name binding)))
|
|
(write-string "undefined imported name " out)
|
|
(if (vm-string? name)
|
|
(write-string (extract-string name) out)
|
|
(write-string "<invalid name>" out))
|
|
(write-char #\newline out))))
|
|
*imported-bindings*)))))
|
|
|
|
;----------------
|
|
; Four primitives for adding and removing imports and exports.
|
|
|
|
(define-consing-primitive lookup-shared-binding (string-> boolean->)
|
|
(lambda (ignore)
|
|
shared-binding-size)
|
|
(lambda (name is-import? key)
|
|
(goto return
|
|
(if is-import?
|
|
(lookup-imported-binding name key)
|
|
(lookup-exported-binding name key)))))
|
|
|
|
(define undefine-shared-binding!
|
|
(table-remover shared-binding-name
|
|
shared-binding-next
|
|
set-shared-binding-next!))
|
|
|
|
(define-primitive undefine-shared-binding (string-> boolean->)
|
|
(lambda (name is-import?)
|
|
(undefine-shared-binding! (if is-import?
|
|
*imported-bindings*
|
|
*exported-bindings*)
|
|
name)
|
|
(goto continue 0)))
|
|
|
|
;----------------
|
|
; The following two functions are exported to C, hence the reversal of the
|
|
; export/import terminology.
|
|
|
|
(define (s48-define-exported-binding name value)
|
|
(receive (key value)
|
|
(ensure-space-saving-temp (+ shared-binding-size
|
|
(vm-string-size (string-length name)))
|
|
value)
|
|
(shared-binding-set! (lookup-imported-binding (enter-string name key) key)
|
|
value)))
|
|
|
|
(define (s48-get-imported-binding name)
|
|
(let ((key (ensure-space (+ shared-binding-size
|
|
(vm-string-size (string-length name))))))
|
|
(lookup-exported-binding (enter-string name key) key)))
|
|
|