scsh-0.5/vm/interp.scm

738 lines
22 KiB
Scheme
Raw Normal View History

1995-10-13 23:34:21 -04:00
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; This is file interp.scm.
; Interpreter state
(define *template* (unassigned))
(define *code-pointer* (unassigned)) ; pointer to next instruction byte
(define *nargs* (unassigned))
(define *val* (unassigned))
(define *enabled-interrupts* (unassigned))
(define *exception-handler* (unassigned))
(define *interrupt-handlers* (unassigned))
(define *dynamic-state* (unassigned))
; Miscellaneous registers
(define *pending-interrupts* (unassigned))
(define *interrupt-template* (unassigned))
(define (clear-registers)
(reset-stack-pointer)
(reserve-exception-space exception-frame-size universal-key)
(set-current-env! unspecific)
(set-template! *interrupt-template* ; has to be some template
(enter-fixnum 0))
(set! *nargs* 0) ; interpreter regs
(set! *val* unspecific)
(set! *dynamic-state* null)
(set! *exception-handler* null)
(set! *interrupt-handlers* null)
(set! *enabled-interrupts* 0)
(set! *pending-interrupts* 0)
unspecific)
(define (trace-registers)
(let ((pc (code-pointer->pc *code-pointer* *template*)))
(set-template! (trace-value *template*) pc))
(set! *val* (trace-value *val*))
(set! *dynamic-state* (trace-value *dynamic-state*))
(set! *exception-handler* (trace-value *exception-handler*))
(set! *interrupt-handlers* (trace-value *interrupt-handlers*))
(set! *interrupt-template* (trace-value *interrupt-template*))
(set-current-env! (trace-value (current-env)))
(trace-stack trace-locations))
(define (set-template! tem pc)
(set! *template* tem)
(set! *code-pointer* (addr+ (address-after-header (template-code tem))
(extract-fixnum pc))))
(define (code-pointer->pc pointer template)
(enter-fixnum (addr- pointer
(address-after-header (template-code template)))))
(define (current-pc)
(code-pointer->pc *code-pointer* *template*))
(define (initialize-interpreter) ;Used only at startup
(set! *interrupt-template*
(make-template-containing-ops (enum op ignore-values)
(enum op return-from-interrupt))))
(define initial-interpreter-heap-space (op-template-size 2))
; Continuations
(define (push-continuation! code-pointer size key)
(let ((pc (code-pointer->pc code-pointer *template*)))
(push-continuation-on-stack *template* pc size key)))
(define (push-exception-continuation!)
(let ((key (allow-exception-consing exception-frame-size)))
(push-continuation! *code-pointer* (arguments-on-stack) key)))
(define (pop-continuation!)
(pop-continuation-from-stack set-template!))
; Instruction stream access
(define (this-byte)
(fetch-byte *code-pointer*))
(define (next-byte)
(let ((b (this-byte)))
(set! *code-pointer* (addr+ *code-pointer* 1))
b))
(define (previous-byte) ;probably not necessary
(set! *code-pointer* (addr+ *code-pointer* -1)))
(define (next-offset)
(let ((high (next-byte)))
(adjoin-bits high (next-byte) bits-used-per-byte)))
(define (nth-offset n)
(set! *code-pointer* (addr+ *code-pointer* (* n 2)))
(next-offset))
(define (next-literal)
(template-ref *template* (next-byte)))
; Return the current op-code. CODE-ARGS is the number of argument bytes that
; have been used.
(define (current-opcode code-args)
(fetch-byte (addr- *code-pointer* (+ code-args 1))))
; Different ways to call the GC.
(define (ensure-space space)
(maybe-ensure-space-saving-temp space (enter-fixnum 0)
(lambda (okay? key temp)
(if (not okay?)
(error "Scheme48 heap overflow"))
key)))
(define (maybe-ensure-space-saving-temp space temp cont)
(if (available? space)
(cont #t (preallocate-space space) temp)
(let ((temp (collect-saving-temp temp)))
(cont (available? space) 0 temp))))
; Actual call to GC
(define *minimum-recovered-space* 0)
(define (collect)
(collect-saving-temp (enter-fixnum 0)))
(define (collect-saving-temp value)
(begin-collection)
(trace-registers)
(trace-impure-areas)
(let ((value (trace-value value)))
(do-gc)
(end-collection)
(close-untraced-ports!)
(if (not (available? *minimum-recovered-space*))
(note-interrupt! (enum interrupt memory-shortage)))
value))
; INTERPRET is the main instruction dispatch for the interpreter.
;(define trace-instructions? #f)
(define (interpret)
; (if trace-instructions?
; (write-instruction *template* (extract-fixnum (current-pc))))
(let ((op-code (next-byte)))
((vector-ref opcode-dispatch op-code))))
;;; Opcodes
(define (uuo) (goto raise-exception 0))
(define opcode-dispatch (make-vector op-count))
(vector+length-fill! opcode-dispatch op-count uuo)
;(define (define-opcode opcode tag)
; (vector-set! opcode-dispatch opcode tag))
(define-syntax define-opcode
(syntax-rules ()
((define-opcode op-name body ...)
(vector-set! opcode-dispatch (enum op op-name) (lambda () body ...)))))
; Check number of arguments
(define-opcode check-nargs=
(if (= *nargs* (next-byte))
(goto interpret)
(goto application-exception 1)))
(define-opcode check-nargs>=
(if (>= *nargs* (next-byte))
(goto interpret)
(goto application-exception 1)))
(define-opcode nargs
(set! *val* (enter-fixnum *nargs*))
(goto interpret))
; Pop off all arguments into a list and raise and exception. *val* is the
; procedure being called. BYTE-ARGS is the number of bytes of the instruction
; stream that the instruction has consumed.
(define (application-exception byte-args)
(let ((args (if (= *nargs* arg-stack-overflow-nargs)
(pop-args-list (pop) maximum-stack-args)
(pop-args-list null *nargs*))))
(goto raise-exception-no-cont2 byte-args *val* args)))
(define (pop-args-list start count)
(let ((key (ensure-space (* vm-pair-size *nargs*))))
(do ((args start (vm-cons (pop) args key))
(count count (- count 1)))
((<= count 0)
args))))
; Create a list to hold all but MIN-ARGS of the available arguments and put
; it in *val*.
; If *nargs* is args-stack-overflow-nargs the top of the stack is a list of
; arguments and not just the last argument.
(define-opcode make-rest-list
(let* ((min-args (next-byte))
(args (if (= *nargs* arg-stack-overflow-nargs)
(pop-args-list (pop) (- (- *nargs* 1) min-args))
(pop-args-list null (- *nargs* min-args)))))
(set! *val* args)
(set! *nargs* (+ min-args 1))
(goto interpret)))
; 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
(let ((key (ensure-stack-space (stack-env-space (this-byte)) ensure-space)))
(pop-args-into-env (next-byte) key)
(goto interpret)))
; The above with the environment in the heap and not on the stack.
(define-opcode make-heap-env
(let ((key (ensure-space (heap-env-space (this-byte)))))
(pop-args-into-heap-env (next-byte) key)
(goto interpret)))
(define-opcode pop-env
(set-current-env! (env-parent (current-env)))
(goto interpret))
; Literals
(define-opcode literal ;Load a literal into *val*.
(set! *val* (next-literal))
(goto interpret))
; Local variable access and assignment
(define-opcode local ;Load value of a local.
(goto finish-local (env-back (current-env) (next-byte)) 2))
(define-opcode local0
(goto finish-local (current-env) 1))
(define-opcode local1
(goto finish-local (env-parent (current-env)) 1))
(define-opcode local2
(goto finish-local (env-parent (env-parent (current-env))) 1))
(define (finish-local env arg-count)
(set! *val* (env-ref env (next-byte)))
(cond ((not (vm-eq? *val* unassigned-marker))
(goto interpret))
(else
(goto raise-exception arg-count))))
(define-opcode set-local!
(let ((back (next-byte)))
(env-set! (env-back (current-env) back)
(next-byte)
*val*)
(set! *val* unspecific)
(goto interpret)))
; Global variable access
(define-opcode global ;Load a global variable.
(let ((location (next-literal)))
(set! *val* (contents location))
(cond ((undefined? *val*) ;unbound or unassigned
(goto raise-exception1 1 location))
(else
(goto interpret)))))
(define-opcode set-global!
(let ((location (next-literal)))
(cond ((vm-eq? (contents location) unbound-marker)
(goto raise-exception2 1 location *val*))
(else
(set-contents! location *val*)
(set! *val* unspecific)
(goto interpret)))))
; Stack operation
(define-opcode push ;Push *val* onto the stack.
(push *val*)
(goto interpret))
(define-opcode pop ;Pop *val* from the stack.
(set! *val* (pop))
(goto interpret))
(define-opcode stack-ref
(set! *val* (stack-ref (next-byte)))
(goto interpret))
(define-opcode stack-set!
(stack-set! (next-byte) *val*)
(goto interpret))
; LAMBDA
(define-opcode closure
(let ((env (preserve-current-env (ensure-space (current-env-size))))
(key (ensure-space closure-size)))
(set! *val* (make-closure (next-literal) env key))
(goto interpret)))
; Procedure call
(define-opcode call
(set! *nargs* (this-byte))
(goto perform-application 0))
; Same as op/call except that the arguments are moved to just above the
; current continuation before the call is made. For non-tail calls and some
; tail-calls the arguments will already be there.
(define-opcode move-args-and-call
(set! *nargs* (this-byte))
(move-args-above-cont! *nargs*)
(goto perform-application 0))
(define-opcode goto-template
(set-template! (next-literal) 0)
(goto interpret))
(define-opcode call-template
(set! *nargs* (next-byte)) ; needed in case of interrupts
(set-template! (next-literal) 0)
(goto poll-for-interrupts))
; Continuation creation and invocation
(define-opcode make-cont ;Start a non-tail call.
(let* ((offset (next-offset))
(size (next-byte))
(key (ensure-stack-space stack-continuation-size ensure-space)))
(push-continuation! (addr+ *code-pointer* offset) size key)
(goto interpret)))
(define-opcode return ;Invoke the continuation.
(pop-continuation!)
(goto interpret))
; The arguments are sitting on the stack, with the count in *nargs*.
; This is only used in the closed-compiled version of VALUES.
(define-opcode values
(goto return-values *nargs*))
; Same as the above, except that the value count is in the instruction stream.
; This is used for in-lining calls to VALUES.
(define-opcode return-values
(goto return-values (this-byte)))
; 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 nargs)
(cond ((= nargs 1)
(set! *val* (pop))
(pop-continuation!)
(goto interpret))
(else
(let ((cont (peek-at-current-continuation)))
(if (continuation? cont)
(goto really-return-values cont nargs)
(goto return-exception nargs))))))
; 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 nargs)
(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))
((= next-op (enum op call-with-values))
(skip-current-continuation!)
(set! *nargs* nargs)
(set! *val* (continuation-ref cont continuation-cells))
(goto perform-application 0))
(else
(goto return-exception nargs)))))
; 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 ((addr= *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! *nargs* nargs)
; (set! *code-pointer* (addr+ *code-pointer* 1)) ; move past (enum op call-with-values
;) (goto interpret))
(define (return-exception nargs)
(let ((args (if (= nargs arg-stack-overflow-nargs)
(pop-args-list (pop) maximum-stack-args)
(pop-args-list null nargs))))
(goto raise-exception1 0 args)))
; This is executed only if the producer returned exactly one value.
(define-opcode call-with-values
(let ((consumer (pop)))
(push *val*)
(set! *val* consumer)
(set! *nargs* 1)
(goto perform-application 0)))
; This is just a marker for the code that handles returns.
(define-opcode ignore-values
(goto interpret))
; IF
(define-opcode jump-if-false
(let ((offset (next-offset)))
(cond ((false? *val*)
(set! *code-pointer* (addr+ *code-pointer* offset))
(goto interpret))
(else
(goto interpret)))))
; Unconditional jump
(define-opcode jump
(let ((offset (next-offset)))
(set! *code-pointer* (addr+ *code-pointer* offset))
(goto interpret)))
; 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*))
(goto raise-exception1 0 *val*)
(let ((max (next-byte))
(val (extract-fixnum *val*)))
(let ((offset (if (and (>= val 0)
(< val max))
(nth-offset val)
(* max 2))))
(set! *code-pointer* (addr+ *code-pointer* offset))
(goto interpret)))))
; Preserve the current continuation and put it in *val*.
(define-opcode current-cont
(let ((key (ensure-space (current-continuation-size))))
(set! *val* (current-continuation key))
(goto interpret)))
(define-opcode with-continuation
(set-current-continuation! (pop))
(set! *nargs* 0)
(goto perform-application 0))
; only used in the stack underflow template
(define-opcode get-cont-from-heap
(let ((cont (get-continuation-from-heap)))
(cond ((not (false? cont))
(set-current-continuation! cont)
(goto interpret))
((fixnum? *val*) ; VM returns here
(set! *val* (extract-fixnum *val*))
(enum return-option exit))
(else
(reset-stack-pointer) ; get a real continuation on the stack
(goto raise-exception1 0 *val*)))))
; APPLY - pop the procedure off of the stack, push each argument from the list,
; and then call the procedure. Tne next byte is the number of arguments that
; have already been pushed on the stack.
(define-opcode apply
(let ((proc (pop)))
(okay-argument-list
*val*
(lambda (length)
(push-argument-list *val* length (this-byte))
(set! *val* proc)
(goto perform-application 0))
(lambda ()
(let ((args (pop-args-list null (this-byte))))
(goto raise-exception3 0 proc args *val*))))))
; If LIST is a proper list (final cdr is null) then OKAY-CONT is called on the
; length of LIST, otherwise LOSE-CONT is called.
(define (okay-argument-list list okay-cont lose-cont)
(let loop ((fast list) (len 0) (slow list) (move-slow? #f))
(cond ((vm-eq? null fast)
(okay-cont len))
((not (vm-pair? fast))
(lose-cont))
((not move-slow?)
(loop (vm-cdr fast) (+ len 1) slow #t))
((vm-eq? fast slow)
(lose-cont))
(else
(loop (vm-cdr fast) (+ len 1) (vm-cdr slow) #f)))))
; Push ARGS onto the stack. LENGTH is the length of the arguments,
; STACK-ARGS is the number of arguments already on the stack.
; If the total number of arguments is greater than the allowed amount,
; the list of extras is copies and pushed.
(define (push-argument-list args length stack-args)
(let* ((nargs (+ length stack-args))
(overflow (if (<= nargs maximum-stack-args)
0
(- nargs maximum-stack-args)))
(rest (push-list args (- length overflow))))
(cond ((= overflow 0)
(set! *nargs* nargs))
(else
(push (copy-arg-list rest overflow))
(set! *nargs* arg-stack-overflow-nargs)))))
; push COUNT elements of LIST onto stack, returning the remainder of LIST
(define (push-list list count)
(do ((i count (- i 1))
(l list (vm-cdr l)))
((<= i 0) l)
(push (vm-car l))))
; Assumes list is non-null
(define (copy-arg-list list length)
(push list)
(let* ((key (ensure-space (* vm-pair-size length)))
(list (pop))
(res (vm-cons (vm-car list) null key)))
(do ((l (vm-cdr list) (vm-cdr l))
(last res (let ((next (vm-cons (vm-car l) null key)))
(vm-set-cdr! last next)
next)))
((vm-eq? null l)
res))))
; Miscellaneous primitive procedures
(define-opcode unassigned
(set! *val* unassigned-marker)
(goto interpret))
(define-opcode unspecific
(set! *val* unspecific)
(goto interpret))
(define-opcode set-exception-handler!
;; New exception handler in *val*
(cond ((not (closure? *val*))
(goto raise-exception1 0 *val*))
(else
(set! *exception-handler* *val*)
(goto interpret))))
(define-opcode set-interrupt-handlers!
;; New interrupt handler vector in *val*
(cond ((or (not (vm-vector? *val*))
(< (vm-vector-length *val*) interrupt-count))
(goto raise-exception1 0 *val*))
(else
(set! *interrupt-handlers* *val*)
(goto interpret))))
(define-opcode set-enabled-interrupts!
;; New interrupt mask as fixnum in *val*
(let ((temp *enabled-interrupts*))
(set! *enabled-interrupts* (extract-fixnum *val*))
(set! *val* (enter-fixnum temp))
(goto interpret)))
;;; Procedure call
; The CLOSURE? check must come before the interrupt check, as the interrupt
; code assumes that the correct template is in place. This delays the
; interrupt handling by a few instructions.
(define (perform-application bytes-consumed)
(cond ((closure? *val*)
(set-current-env! (closure-env *val*))
(set-template! (closure-template *val*) 0)
(goto poll-for-interrupts))
(else
(goto application-exception bytes-consumed))))
(define (poll-for-interrupts)
(if (= 0 (bitwise-and *pending-interrupts* *enabled-interrupts*))
(goto interpret)
(goto handle-interrupt)))
; 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.
(define exception-frame-size ; a continuation plus up to five arguments
(+ stack-continuation-size 5)) ; one of which is the opcode
(define (start-exception args)
(push-exception-continuation!)
(push (enter-fixnum (current-opcode args))))
(define (raise-exception args)
(start-exception args)
(goto raise 0))
(define (raise-exception1 args a1)
(start-exception args)
(push a1)
(goto raise 1))
(define (raise-exception2 args a1 a2)
(start-exception args)
(push a1)
(push a2)
(goto raise 2))
(define (raise-exception-no-cont2 args a1 a2)
(push (enter-fixnum (current-opcode args)))
(push a1)
(push a2)
(goto raise 2))
(define (raise-exception3 args a1 a2 a3)
(start-exception args)
(push a1)
(push a2)
(push a3)
(goto raise 3))
(define (raise-exception4 args a1 a2 a3 a4)
(start-exception args)
(push a1)
(push a2)
(push a3)
(push a4)
(goto raise 4))
(define no-exceptions? #f)
(define (raise nargs)
; (if no-exceptions?
; (breakpoint "exception check" nargs))
(set! *nargs* (+ nargs 1)) ; extra arg is the op-code
(set! *val* *exception-handler*)
(if (not (closure? *val*))
(error "exception handler is not a closure"))
(reserve-exception-space exception-frame-size
(ensure-stack-space exception-frame-size
ensure-space))
(goto perform-application 0))
; Interrupts
; This is only called when a template is about to be jumped to, so the only
; values that must be saved are *env*, *template*, *nargs*, and
; *enabled-interrupts*.
(define (handle-interrupt)
(let ((key (ensure-stack-space stack-continuation-size ensure-space))
(interrupt (get-highest-priority-interrupt!)))
(push *val*) ; may be needed for nargs exception
(push *template*)
(push (current-env))
(push (enter-fixnum *nargs*))
(push (enter-fixnum *enabled-interrupts*))
(set-template! *interrupt-template* (enter-fixnum 0))
(push-continuation! *code-pointer* (+ *nargs* 5) key)
(push (enter-fixnum *enabled-interrupts*))
(set! *nargs* 1)
(if (not (vm-vector? *interrupt-handlers*))
(error "interrupt handler is not a vector"))
(set! *val* (vm-vector-ref *interrupt-handlers* interrupt))
(set! *enabled-interrupts* 0) ;Disable all interrupts
(if (not (closure? *val*))
(error "interrupt handler is not a closure" interrupt))
(goto perform-application 0)))
(define-opcode return-from-interrupt
(set! *enabled-interrupts* (extract-fixnum (pop)))
(set! *nargs* (extract-fixnum (pop)))
(set-current-env! (pop))
(set-template! (pop) 0)
(set! *val* (pop))
(goto interpret))
(define (get-highest-priority-interrupt!)
(let ((n (bitwise-and *pending-interrupts* *enabled-interrupts*)))
(let loop ((i 0) (m 1))
(cond ((= 0 (bitwise-and n m))
(loop (+ i 1) (* m 2)))
(else
(set! *pending-interrupts* (bitwise-and n (bitwise-not m)))
i)))))
(define (note-interrupt! interrupt)
(set! *pending-interrupts*
(bitwise-ior *pending-interrupts*
(ashl 1 interrupt))))
(define (clear-interrupt! interrupt)
(set! *pending-interrupts*
(bitwise-and *pending-interrupts*
(bitwise-not (ashl 1 interrupt)))))