; -*- 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)))))