scsh-0.6/scheme/vm/interp.scm

699 lines
21 KiB
Scheme
Raw Normal View History

1999-09-14 08:45:02 -04:00
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
;Need to fix the byte-code compiler to make jump etc. offsets from the
;beginning of the instruction.
; This is file interp.scm.
; Interpreter state
(define *template*) ; current template
(define *code-pointer*) ; pointer to next instruction byte
(define *val*) ; last value produced
(define *exception-handlers*) ; vector of procedures, one per opcode
(define *interrupt-handlers*) ; vector of procedures, one per interrupt type
; Two registers used only by the RTS (except for one hack; see GET-CURRENT-PORT
; in prim-io.scm).
(define *current-thread*) ; dynamic state
(define *session-data*) ; session state
; Finalizers
(define *finalizer-alist*) ; list of (<thing> . <procedure>) pairs
(define *finalize-these*) ; list of such pairs that should be executed
; Interrupts
(define *enabled-interrupts*) ; bitmask of enabled interrupts
(define s48-*pending-interrupt?*) ; true if an interrupt is pending
(define *interrupted-template*) ; template in place when the most recent
; interrupt occured - for profiling
(define *interrupt-template*) ; used to return from interrupts
(define *exception-template*) ; used to mark exception continuations
; These are referred to from other modules.
(define (val) *val*)
(define (set-val! val) (set! *val* val))
(define (code-pointer) *code-pointer*)
(define (current-thread) *current-thread*)
;----------------
(define (clear-registers)
(reset-stack-pointer false)
(set-current-env! unspecific-value)
(set-template! *interrupt-template* ; has to be some template
(enter-fixnum 0))
(set! *val* unspecific-value)
(set! *current-thread* null)
(set! *session-data* null)
(set! *exception-handlers* null)
(set! *interrupt-handlers* null)
(set! *enabled-interrupts* 0)
(set! *finalizer-alist* null)
(set! *finalize-these* null)
(pending-interrupts-clear!)
1999-09-14 08:45:02 -04:00
(set! s48-*pending-interrupt?* #f)
(set! *interrupted-template* false)
unspecific-value)
(define *saved-pc*) ; for saving the pc across GC's
(add-gc-root!
(lambda ()
(set! *saved-pc* (current-pc)) ; headers may be busted here...
(set! *template* (s48-trace-value *template*))
(set! *val* (s48-trace-value *val*))
(set! *current-thread* (s48-trace-value *current-thread*))
(set! *session-data* (s48-trace-value *session-data*))
(set! *exception-handlers* (s48-trace-value *exception-handlers*))
(set! *exception-template* (s48-trace-value *exception-template*))
(set! *interrupt-handlers* (s48-trace-value *interrupt-handlers*))
(set! *interrupt-template* (s48-trace-value *interrupt-template*))
(set! *interrupted-template* (s48-trace-value *interrupted-template*))
(set! *finalize-these* (s48-trace-value *finalize-these*))
2002-06-10 04:46:08 -04:00
(set! *os-signal-list* (s48-trace-value *os-signal-list*))
1999-09-14 08:45:02 -04:00
(trace-finalizer-alist!)
; These could be moved to the appropriate modules.
(set-current-env! (s48-trace-value (current-env)))
(trace-io s48-trace-value)
(trace-stack s48-trace-locations! s48-trace-stob-contents! s48-trace-value)))
(add-post-gc-cleanup!
(lambda ()
(set-template! *template* *saved-pc*)
(partition-finalizer-alist!)
(close-untraced-channels!)
(note-interrupt! (enum interrupt post-gc))))
;----------------
; Dealing with the list of finalizers.
;
; Pre-gc:
; Trace the contents of every finalizer object, updating them in oldspace.
; If any contains a pointer to itself, quit and trace it normally.
; If any have already been copied, ignore it.
; Post-gc:
; Check each to see if each has been copied. If not, copy it. There is
; no need to trace any additional pointers.
; Walk down the finalizer alist, tracing the procedures and the contents of
; the things.
(define (trace-finalizer-alist!)
(let loop ((alist *finalizer-alist*))
(if (not (vm-eq? alist null))
(let* ((pair (vm-car alist)))
(if (not (s48-extant? (vm-car pair))) ; if not already traced
(s48-trace-stob-contents! (vm-car pair)))
(vm-set-cdr! pair (s48-trace-value (vm-cdr pair)))
(loop (vm-cdr alist))))))
; Walk down the finalizer alist, separating out the pairs whose things
; have been copied.
(define (partition-finalizer-alist!)
(let loop ((alist *finalizer-alist*) (okay null) (goners null))
(if (vm-eq? alist null)
(begin
(set! *finalizer-alist* okay)
(set! *finalize-these* (vm-append! goners *finalize-these*)))
(let* ((alist (s48-trace-value alist))
(pair (s48-trace-value (vm-car alist)))
(thing (vm-car pair))
(next (vm-cdr alist))
(traced? (s48-extant? thing)))
(vm-set-car! pair (s48-trace-value thing))
(vm-set-car! alist pair)
(cond (traced?
(vm-set-cdr! alist okay)
(loop next alist goners))
(else
(vm-set-cdr! alist goners)
(loop next okay alist)))))))
(define (vm-append! l1 l2)
(if (vm-eq? l1 null)
l2
(let ((last-pair (let loop ((l l1))
(if (vm-eq? (vm-cdr l) null)
l
(loop (vm-cdr l))))))
(vm-set-cdr! last-pair l2)
l1)))
;----------------
(define (set-template! tem pc)
(set! *template* tem)
(set-code-pointer! (template-code tem) (extract-fixnum pc)))
(define (set-code-pointer! code pc)
(set! *code-pointer* (address+ (address-after-header code) pc)))
(define (code-pointer->pc pointer template)
(enter-fixnum (address-difference
pointer
(address-after-header (template-code template)))))
(define (current-pc)
(code-pointer->pc *code-pointer* *template*))
(define (initialize-interpreter+gc) ;Used only at startup
(let ((key (ensure-space (op-template-size 2))))
(set! *interrupt-template*
(make-template-containing-ops (enum op ignore-values)
(enum op return-from-interrupt)
key))
(set! *exception-template*
(make-template-containing-ops (enum op return-from-exception)
(enum op false) ; ignored
key))))
;----------------
; Continuations
(define (push-continuation! code-pointer size)
(let ((pc (code-pointer->pc code-pointer *template*)))
(push-continuation-on-stack *template* pc size)))
(define (pop-continuation!)
(pop-continuation-from-stack set-template!))
;----------------
; Instruction stream access
(define (code-byte index)
(fetch-byte (address+ *code-pointer* (+ index 1))))
(define (code-offset index)
(adjoin-bits (code-byte index)
(code-byte (+ index 1))
bits-used-per-byte))
(define (get-literal index)
(template-ref *template* (code-offset index)))
; Return the current op-code. CODE-ARGS is the number of argument bytes that
; have been used.
(define (current-opcode)
(code-byte -1))
; INTERPRET is the main instruction dispatch for the interpreter.
;(define trace-instructions? #f)
;(define *bad-count* 0)
;(define *i* 0)
(define (interpret code-pointer)
; (if (and trace-instructions? (> *i* *bad-count*))
; (write-instruction *template* (extract-fixnum (current-pc)) 1 #f))
; (set! *i* (+ *i* 1))
((vector-ref opcode-dispatch (fetch-byte code-pointer))))
(define (continue bytes-used)
(set! *code-pointer* (address+ *code-pointer* (+ bytes-used 1)))
(goto interpret *code-pointer*))
(define (continue-with-value value bytes-used)
(set! *val* value)
(goto continue bytes-used))
;----------------
; Opcodes
(define (uuo)
(raise-exception unimplemented-instruction 0))
(define opcode-dispatch (make-vector op-count))
(vector+length-fill! opcode-dispatch op-count uuo)
(define-syntax define-opcode
(syntax-rules ()
((define-opcode op-name body ...)
(vector-set! opcode-dispatch (enum op op-name) (lambda () body ...)))))
;----------------
; Exception syntax
; For restartable exceptions the saved code-pointer points to the instruction
; following the offending one. For all other exceptions it points to the
; offending instruction.
;
; The ...* versions evaluate the exception enum argument, the plain ones
; invoke the enumeration.
(define-syntax raise-exception
(syntax-rules ()
((raise-exception why byte-args stuff ...)
(raise-exception* (enum exception why) byte-args stuff ...))))
(define-syntax count-exception-args
(syntax-rules ()
((count-exception-args) 0)
((count-exception-args arg1 rest ...)
(+ 1 (count-exception-args rest ...)))))
(define-syntax raise-exception*
(syntax-rules ()
((raise-exception* why byte-args arg1 ...)
(begin
(push-exception-continuation! why (+ byte-args 1)) ; add 1 for the opcode
(push arg1) ...
(goto raise (count-exception-args arg1 ...))))))
;----------------
; Exceptions
; The system reserves enough stack space to allow for an exception at any time.
; If the reserved space is used a gc must be done before the exception handler
; is called.
; New exception handlers in *val*.
(define-opcode set-exception-handlers!
(cond ((or (not (vm-vector? *val*))
(< (vm-vector-length *val*) op-count))
(raise-exception wrong-type-argument 0 *val*))
(else
(let ((temp *exception-handlers*))
(set! *exception-handlers* *val*)
(goto continue-with-value
temp
0)))))
; The current opcode and the exception are pushed as arguments to the handler.
; INSTRUCTION-SIZE is the size of the current instruction and is used to jump
; to the next instruction when returning. The exception is saved in the
; continuation for use in debugging.
(define (push-exception-continuation! exception instruction-size)
(let ((opcode (current-opcode)))
(push (enter-fixnum instruction-size))
(push (enter-fixnum exception))
(push *template*)
(push (current-pc))
(set-template! *exception-template* (enter-fixnum 0))
(push-continuation! *code-pointer* (arguments-on-stack))
(push (enter-fixnum opcode))
(push (enter-fixnum exception))))
(define-opcode return-from-exception
(let* ((pc (extract-fixnum (pop)))
(template (pop))
(exception (pop)) ; ignored
(size (extract-fixnum (pop))))
(set-template! template (enter-fixnum (+ pc size)))
(goto interpret *code-pointer*)))
;(define no-exceptions? #t)
(define (raise nargs)
; (let ((opcode (enumerand->name (extract-fixnum (stack-ref (+ nargs 1))) op))
; (why (enumerand->name (extract-fixnum (stack-ref nargs)) exception)))
; (if (and no-exceptions?
; (not (and (eq? 'write-char opcode)
; (eq? 'buffer-full/empty why))))
; (breakpoint "exception check ~A ~A ~A" opcode why nargs)))
;; try to be helpful when all collapses
(let* ((opcode (extract-fixnum (stack-ref (+ nargs 1))))
(lose (lambda (message)
(let ((why (extract-fixnum (stack-ref nargs))))
(write-string "Template UIDs: " (current-error-port))
(report-continuation-uids *template* (current-error-port))
(newline (current-error-port))
(if (and (eq? why (enum exception undefined-global))
(fixnum? (location-id (stack-ref (- nargs 1)))))
(error message opcode why
(extract-fixnum (location-id (stack-ref (- nargs 1)))))
(error message opcode why))))))
(if (not (vm-vector? *exception-handlers*))
(lose "exception-handlers is not a vector"))
(set! *val* (vm-vector-ref *exception-handlers* opcode))
(if (not (closure? *val*))
(lose "exception handler is not a closure"))
(goto call-exception-handler (+ nargs 2) opcode)))
;----------------
; Literals
; Loaded from *template* into *val*, using either a one-byte or two-byte index.
(define-opcode literal ;Load a literal into *val*.
(goto continue-with-value
(get-literal 0)
2)) ; offset
(define-opcode small-literal
(goto continue-with-value
(template-ref *template* (code-byte 0))
2)) ; byte + wasted byte
;----------------
; Environment creation
; The MAKE-ENV instruction adds a env to the local environment.
; It pops values off the stack and stores them into the new env.
(define-opcode make-env
(pop-args-into-env (code-offset 0))
(goto continue 2)) ; offset
; Local variable access and assignment
(define-opcode local ;Load value of a local.
(goto finish-local (env-back (current-env) (code-byte 0)) 1))
(define-opcode local0
(goto finish-local (current-env) 0))
(define-opcode push-local0
(push *val*)
(goto finish-local (current-env) 1))
(define-opcode local0-push
(set! *val* (env-ref (current-env) (code-byte 0)))
(if (not (vm-eq? *val* unassigned-marker))
(begin
(push *val*)
(goto continue 2))
(raise-exception unassigned-local 2)))
(define-opcode local1
(goto finish-local (env-parent (current-env)) 0))
(define-opcode local2
(goto finish-local (env-parent (env-parent (current-env))) 0))
(define (finish-local env arg-count)
(set! *val* (env-ref env (code-byte arg-count)))
(if (not (vm-eq? *val* unassigned-marker))
(goto continue (+ arg-count 1))
(raise-exception unassigned-local (+ arg-count 1))))
(define-opcode big-local
(let ((back (code-offset 0)))
(set! *val* (env-ref (env-back (current-env) back)
(code-offset 2)))
(if (not (vm-eq? *val* unassigned-marker))
(goto continue 4) ; byte + offset
(raise-exception unassigned-local 4))))
(define-opcode set-local!
(let ((back (code-offset 0)))
(env-set! (env-back (current-env) back)
(code-offset 2)
*val*)
(set! *val* unspecific-value)
(goto continue 4))) ; byte + offset
;----------------
; Global variable access
(define-opcode global ;Load a global variable.
(let ((location (get-literal 0)))
(set! *val* (contents location))
(if (undefined? *val*) ;unbound or unassigned
(raise-exception undefined-global 2 location)
(goto continue 2)))) ; offset
(define-opcode set-global!
(let ((location (get-literal 0)))
(cond ((vm-eq? (contents location) unbound-marker)
(raise-exception undefined-global 2 location *val*))
(else
(set-contents! location *val*)
(goto continue-with-value
unspecific-value
2))))) ; offset
;----------------
; Stack operation
(define-opcode push ;Push *val* onto the stack.
(push *val*)
(goto continue 0))
(define-opcode pop ;Pop *val* from the stack.
(goto continue-with-value
(pop)
0))
(define-opcode stack-ref
(goto continue-with-value
(stack-ref (code-byte 0))
1))
(define-opcode stack-set!
(stack-set! (code-byte 0) *val*)
(goto continue 1))
;----------------
; LAMBDA
(define-opcode closure
(let ((env (if (= 0 (code-byte 2))
(preserve-current-env (ensure-space (current-env-size)))
*val*)))
(receive (key env)
(ensure-space-saving-temp closure-size env)
(goto continue-with-value
(make-closure (get-literal 0) env key)
3))))
; Looks like:
; (enum op make-flat-env)
; number of vars
; use *val* as first element?
; depth of first level
; number of vars in level
; offsets of vars in level
; delta of depth of second level
; ...
(define-opcode make-flat-env
(let* ((total-count (code-byte 1))
(new-env (vm-make-vector total-count
(ensure-space (vm-vector-size total-count))))
(start-i (if (= 0 (code-byte 0))
0
(begin
(vm-vector-set! new-env 0 *val*)
1))))
(let loop ((i start-i)
(offset 2) ; count and use-*val*
(env (current-env)))
(if (= i total-count)
(goto continue-with-value
new-env
offset)
(let ((env (env-back env (code-byte offset)))
(count (code-byte (+ offset 1))))
(do ((count count (- count 1))
(i i (+ i 1))
(offset (+ offset 2) (+ offset 1))) ; env-back and count
((= count 0)
(loop i offset env))
(vm-vector-set! new-env
i
(vm-vector-ref env
(code-byte offset)))))))))
;----------------
; Continuation creation and invocation
(define-opcode make-cont ;Start a non-tail call.
(push-continuation! (address+ *code-pointer*
(code-offset 0))
(code-byte 2))
(goto continue 3))
(define-opcode make-big-cont ;Start a non-tail call.
(push-continuation! (address+ *code-pointer*
(code-offset 0))
(code-offset 2))
(goto continue 4))
(define-opcode return ;Invoke the continuation.
(pop-continuation!)
(goto interpret *code-pointer*))
; This is only used in the closed-compiled version of VALUES.
; Stack is: arg0 arg1 ... argN rest-list N+1 total-arg-count.
; If REST-LIST is non-empty then there are at least two arguments on the stack.
(define-opcode closed-values
(let* ((nargs (extract-fixnum (pop)))
(stack-nargs (extract-fixnum (pop)))
(rest-list (pop)))
(goto return-values stack-nargs rest-list (- nargs stack-nargs))))
; Same as the above, except that the value count is in the instruction stream
; and all of the arguments are on the stack.
; This is used for in-lining calls to VALUES.
(define-opcode values
(goto return-values (code-offset 0) null 0))
; STACK-NARGS return values are on the stack. If there is only one value, pop
; it off and do a normal return. Otherwise, find the actual continuation
; and see if it ignores the values, wants the values, or doesn't know
; anything about them.
(define (return-values stack-nargs list-args list-arg-count)
(cond ((= stack-nargs 1) ; if list-arg-count > 0 then stack-nargs > 1
(set! *val* (pop))
(pop-continuation!)
(goto interpret *code-pointer*))
(else
(let ((cont (peek-at-current-continuation)))
(if (continuation? cont)
(goto really-return-values
cont stack-nargs list-args list-arg-count)
(goto return-exception stack-nargs list-args))))))
; If the next op-code is:
; op/ignore-values - just return, ignoring the return values
; op/call-with-values - remove the continuation containing the consumer
; (the consumer is the only useful information it contains), and then call
; the consumer.
; anything else - only one argument was expected so raise an exception.
(define (really-return-values cont stack-nargs list-args list-arg-count)
(let ((next-op (code-vector-ref (template-code (continuation-template cont))
(extract-fixnum (continuation-pc cont)))))
(cond ((= next-op (enum op ignore-values))
(pop-continuation!)
(goto interpret *code-pointer*))
((= next-op (enum op call-with-values))
(skip-current-continuation!)
(set! *val* (continuation-ref cont continuation-cells))
(goto perform-application-with-rest-list stack-nargs
list-args
list-arg-count))
(else
(goto return-exception stack-nargs list-args)))))
; This would avoid the need for the consumer to be a closure. It doesn't
; work because the NARGS check (which would be the next instruction to be
; executed) assumes that a closure has just been called.
;(define (do-call-with-values nargs)
; (cond ((address= *cont* *bottom-of-stack*)
; (restore-from-continuation (continuation-cont *cont*))
; (set-continuation-cont! *bottom-of-stack* *cont*)
; (set! *cont* *bottom-of-stack*))
; (else
; (restore-from-continuation cont)))
; (set! *code-pointer* (address+ *code-pointer* 1)) ; move past (enum op call-with-values
;) (goto interpret *code-pointer*))
(define (return-exception stack-nargs list-args)
(let ((args (pop-args->list* list-args stack-nargs)))
(raise-exception wrong-number-of-arguments -1 false args))) ; no next opcode
; This is executed only if the producer returned exactly one value.
(define-opcode call-with-values
(let ((consumer (pop)))
(push *val*)
(set! *val* consumer)
(goto perform-application 1)))
; This is just a marker for the code that handles returns.
(define-opcode ignore-values
(goto continue 0))
;----------------
; Preserve the current continuation and put it in *val*.
(define-opcode current-cont
(let ((key (ensure-space (current-continuation-size))))
(goto continue-with-value
(current-continuation key)
0)))
(define-opcode with-continuation
(set-current-continuation! (pop))
(goto perform-application 0))
; only used in the stack underflow template
(define-opcode get-cont-from-heap
(let ((cont (get-continuation-from-heap)))
(cond ((continuation? cont)
(set-current-continuation! cont)
(goto continue 0))
((and (false? cont)
(fixnum? *val*)) ; VM returns here
(set! s48-*callback-return-stack-block* false) ; not from a callback
2002-05-16 10:50:46 -04:00
(reset-stack-pointer false) ; for libscsh
1999-09-14 08:45:02 -04:00
(extract-fixnum *val*))
(else
(set-current-continuation! false)
(raise-exception wrong-type-argument 0 *val* cont)))))
;----------------
; Control flow
; IF
(define-opcode jump-if-false
(cond ((false? *val*)
(set! *code-pointer*
(address+ *code-pointer*
(code-offset 0)))
(goto interpret *code-pointer*))
(else
(goto continue 2))))
; Unconditional jump
(define-opcode jump
(set! *code-pointer*
(address+ *code-pointer*
(code-offset 0)))
(goto interpret *code-pointer*))
; Computed goto
; Goto index is in *val*, the next byte is the number of offsets specified
; The default is to jump to the instruction following the offsets
; The instruction stream looks like
; op/computed-goto max offset0 offset1 ... offsetmax-1 code-for-default...
(define-opcode computed-goto
(if (not (fixnum? *val*))
(raise-exception wrong-type-argument -1 *val*) ; back up over opcode
(let ((max (code-byte 0))
(val (extract-fixnum *val*)))
(let ((offset (if (and (>= val 0)
(< val max))
(code-offset (+ (* val 2) 1))
(+ (* max 2) 2))))
(set! *code-pointer* (address+ *code-pointer* offset))
(goto interpret *code-pointer*)))))
;----------------
; Miscellaneous primitive procedures
(define-opcode unassigned
(goto continue-with-value
unassigned-marker
0))
(define-opcode unspecific
(goto continue-with-value
unspecific-value
0))