; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.

; Code to handle the calling conventions.

; *VAL* is the procedure, the arguments are on stack, and the next byte
; is the protocol.  This checks that *VAL* is in fact a closure and checks
; for the common case of a non-n-ary procedure that has few arguments.
; The common case is handled directly and all others are passed off to
; PLAIN-PROTOCOL-MATCH.

(define-opcode call
  (let ((stack-arg-count (code-byte 0)))
    (if (closure? *val*)
	(let* ((template (closure-template *val*))
	       (code (template-code template)))
	  (if (= stack-arg-count (code-vector-ref code 1))
	      (begin
		(set! *template* template)
		(set-current-env! (closure-env *val*))
		(set-code-pointer! code 2)
		(ensure-default-procedure-space! ensure-space)
		(if (pending-interrupt?)
		    (goto handle-interrupt stack-arg-count)
		    (goto interpret *code-pointer*)))
	      (goto plain-protocol-match stack-arg-count)))
	(goto application-exception
	      (enum exception bad-procedure)
	      stack-arg-count null 0))))

; Two bytes of arguments.

(define-opcode big-call
  (goto perform-application (code-offset 0)))

; Call a template instead of a procedure.  This is currently only used for
; stringing together the initialization code made by the static linker.
;
; **limitation**: this code only works for templates that take no arguments.

(define-opcode call-template
  (let ((win (lambda ()
	       (set-template! (get-literal 0)
			      (enter-fixnum 2)) ; skip the protocol
	       (if (pending-interrupt?)
		   (goto handle-interrupt (code-byte 2))  ; pass nargs count
		   (goto interpret *code-pointer*))))
	(code (template-code (get-literal 0))))
    (cond ((= 0 (code-vector-ref code 1))
	   (ensure-default-procedure-space! ensure-space)
	   (win))
	  ((and (= big-stack-protocol (code-vector-ref code 1))
		(= 0 (code-vector-ref code (- (code-vector-length code) 3))))
	   (ensure-stack-space! (code-vector-ref16
				   code
				   (- (code-vector-length code) 2))
				ensure-space)
	   (win))
	  (else
	   (raise-exception wrong-type-argument 3 (get-literal 0))))))

; The following two instructions are used only for experiments.  The compiler
; does not normally use them.
;
; 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
  (let ((nargs (code-byte 0)))
    (move-args-above-cont! nargs)
    (goto perform-application nargs)))

(define-opcode goto-template
  (set-template! (get-literal 0) (enter-fixnum 0))
  (goto interpret *code-pointer*))

; APPLY: *VAL* is the procedure, the rest-arg list is on top of the stack,
; the next two bytes are the number of stack arguments below the rest-args list.
; We check that the rest-arg list is a proper list and let
; PERFORM-APPLICATION-WITH-REST-LIST do the work.
    
(define-opcode apply
  (let ((list-args (pop)))
    (receive (okay? length)
	(okay-argument-list list-args)
      (if okay?
	  (goto perform-application-with-rest-list
		(code-offset 0) list-args length)
	  (begin
	    (push list-args)
	    (let ((args (pop-args->list* null (+ (code-offset 0) 1))))
	      (raise-exception wrong-type-argument -1 *val* args))))))) ; no next

; This is only used for the closed-compiled version of APPLY.
;
; Stack = arg0 arg1 ... argN rest-list N+1 total-arg-count
; Arg0 is the procedure.
;
; Note that the rest-list on the stack is the rest-list passed to APPLY
; procedure and not the rest-list to be used in the call to the procedure.
; Consider (APPLY APPLY (LIST LIST '(1 2 3))), where the initial APPLY
; is not done in-line.  The stack for the inner call to APPLY will be
; [(<list-procedure> (1 2 3)), 1, 2], whereas for
; (APPLY APPLY LIST 1 '(2 (3))) the stack will be
; [<list-procedure>, 1, (2 (3)), 3, 4].
;
; We grab the counts and the procedure, and clobber the procedure's stack
; slot for GC safety.  Then we get the true stack-arg count and list args
; and again let PERFORM-APPLICATION-WITH-REST-LIST do the work.

(define-opcode closed-apply
  (let* ((nargs (extract-fixnum (pop)))
	 (stack-nargs (extract-fixnum (pop)))
	 (proc (stack-ref stack-nargs)))
    (stack-set! stack-nargs false)
    (receive (okay? stack-arg-count list-args list-arg-count)
	(get-closed-apply-args nargs stack-nargs)
      (if okay?
	  (begin
	    (set! *val* proc)
	    (goto perform-application-with-rest-list
		  stack-arg-count
		  list-args
		  list-arg-count))
	  (begin
	    (push list-args)
	    (let ((args (pop-args->list* null (+ stack-arg-count 1))))
	      (pop)	; remove procedure
	      (raise-exception wrong-type-argument -1 proc args)))))))

; Stack = arg0 arg1 ... argN rest-list
; This needs to get the last argument, which is either argN or the last
; element of the rest-list, and splice it into the rest of the arguments.
; If the rest-list is null, then argN is the last argument and becomes the
; new rest-list.  If the rest-list is non-null, then we go to the end, get
; the list there, and splice the two together to make a single list.
; This only happens if someone does (APPLY APPLY ...).

(define (get-closed-apply-args nargs stack-nargs)
  (let ((rest-list (pop)))
    (receive (list-args stack-nargs)
	(cond ((vm-eq? rest-list null)
	       (values (pop)
		       (- stack-nargs 2))) ; drop proc and final list
	      ((vm-eq? (vm-cdr rest-list) null)
	       (values (vm-car rest-list)
		       (- stack-nargs 1))) ; drop proc
	      (else
	       (let* ((penultimate-cdr (penultimate-cdr rest-list))
		      (list-args (vm-car (vm-cdr penultimate-cdr))))
		 (vm-set-cdr! penultimate-cdr list-args)
		 (values rest-list
			 (- stack-nargs 1))))) ; drop proc
      (receive (okay? list-arg-count)
	  (okay-argument-list list-args)
	(values okay?
		stack-nargs
		list-args
		list-arg-count)))))

; If LIST is a proper list (the final cdr is null) then we return #T and the
; length of the list, otherwise we return #F.

(define (okay-argument-list list)
  (let loop ((fast list) (len 0) (slow list) (move-slow? #f))
    (cond ((vm-eq? null fast)
	   (values #t len))
	  ((or (not (vm-pair? fast)))
	   (values #f 0))
	  ((not move-slow?)
	   (loop (vm-cdr fast) (+ len 1) slow #t))
	  ((vm-eq? fast slow)
	   (values #f 0))
	  (else
	   (loop (vm-cdr fast) (+ len 1) (vm-cdr slow) #f)))))

; Return the second-to-last cdr of LIST.

(define (penultimate-cdr list)
  (let loop ((list (vm-cdr (vm-cdr list))) (follower list))
    (if (eq? null list)
	follower
	(loop (vm-cdr list) (vm-cdr follower)))))

;----------------
; Call the procedure in *VAL*.  STACK-ARG-COUNT is the number of arguments
; on the stack, LIST-ARGS is a list of LIST-ARG-COUNT additional arguments.
;
; The CLOSURE? and protocol checks must come before the interrupt check because
; the interrupt code assumes that the correct template is in place.  This delays
; the handling of interrupts by a few instructions; it shouldn't matter.

(define (perform-application stack-arg-count)
  (if (closure? *val*)
      (goto plain-protocol-match stack-arg-count)
      (goto application-exception
	    (enum exception bad-procedure)
	    stack-arg-count null 0)))

(define (perform-application-with-rest-list stack-arg-count
					    list-args list-arg-count)
  (cond ((= 0 list-arg-count)
	 (goto perform-application stack-arg-count))
	((closure? *val*)
	 (goto list-protocol-match
	       stack-arg-count list-args list-arg-count))
	(else
	 (goto application-exception
	       (enum exception bad-procedure)
	       stack-arg-count list-args list-arg-count))))

(define (install-*val*-closure skip)
  (let ((template (closure-template *val*)))
    (set! *template* template)
    (set-code-pointer! (template-code template) skip)
    (set-current-env! (closure-env *val*))))

(define (check-interrupts-and-go stack-slots stack-arg-count)
  (ensure-stack-space! stack-slots ensure-space)
  (if (pending-interrupt?)
      (goto handle-interrupt stack-arg-count)
      (goto interpret *code-pointer*)))

(define (wrong-nargs stack-arg-count list-args list-arg-count)
  (goto application-exception
	(enum exception wrong-number-of-arguments)
	stack-arg-count list-args list-arg-count))

; Used by RAISE which can't raise an exception when an error occurs.

(define *losing-opcode* 0)

(define (call-exception-handler stack-arg-count opcode)
  (set! *template* *val*)  ; Use *VAL* (a closure) as a marker.
  (set! *losing-opcode* opcode)
  (goto plain-protocol-match stack-arg-count))

(define (call-interrupt-handler stack-arg-count interrupt)
  (set! *template* *val*)  ; Use *VAL* (a closure) as a marker.
  (set! *losing-opcode* (- interrupt))
  (goto plain-protocol-match stack-arg-count))

; Check that the arguments match those needed by *VAL*, which is a closure,
; moving arguments to or from the stack if necessary, and ensure that there
; is enough stack space for the procedure.  The environment needed by *VAL*
; is created.

(define (plain-protocol-match stack-arg-count)
  (let ((code (template-code (closure-template *val*)))
	(lose (lambda ()
		(goto wrong-nargs stack-arg-count null 0))))
    (assert (= (enum op protocol)
	       (code-vector-ref code 0)))
    (let loop ((protocol (code-vector-ref code 1))
	       (stack-space default-stack-space))
      (let ((win (lambda (skip stack-arg-count)
		   (install-*val*-closure skip)
		   (goto check-interrupts-and-go stack-space stack-arg-count))))
	(let (;; Fixed number of arguments.
	      (fixed-match (lambda (wants skip)
			     (if (= wants stack-arg-count)
				 (win skip stack-arg-count)
				 (lose))))
	      ;; N-ary procedure.
	      (n-ary-match (lambda (wants-stack-args skip)
			     (if (<= wants-stack-args stack-arg-count)
				 (begin
				   (rest-list-setup wants-stack-args
						    stack-arg-count
						    null
						    0)
				   (win skip (+ wants-stack-args 1)))
				 (lose))))
	      ;; Push the rest list, the total number of arguments, and the
	      ;; number on the stack arguments onto the stack.
	      (args+nargs-match (lambda (skip)
				  (push null)
				  (push (enter-fixnum stack-arg-count))
				  (push (enter-fixnum stack-arg-count))
				  (win skip (+ stack-arg-count 3)))))
	  (cond ((= protocol nary-dispatch-protocol)
		 (if (< stack-arg-count 3)
		     (let ((skip (code-vector-ref code (+ 2 stack-arg-count))))
		       (if (= 0 skip)
			   (lose)
			   (win skip stack-arg-count)))
		     (let ((skip (code-vector-ref code 5)))
		       (if (= 0 skip)
			   (lose)
			   (args+nargs-match skip)))))
		((= protocol args+nargs-protocol)
		 (if (>= stack-arg-count
			 (code-vector-ref code 2))
		     (args+nargs-match 3)
		     (lose)))
		((= protocol two-byte-nargs+list-protocol)
		 (n-ary-match (code-vector-ref16 code 2) 4))
		((<= protocol maximum-stack-args)
		 (fixed-match protocol 2))
		((= protocol two-byte-nargs-protocol)
		 (fixed-match (code-vector-ref16 code 2) 4))
		((= protocol big-stack-protocol)
		 (let ((length (code-vector-length code)))
		   (loop (code-vector-ref code (- length 3))
			 (code-vector-ref16 code (- length 2)))))
		(else
		 (error "unknown protocol" protocol)
		 (lose))))))))

; Same thing, except that there is an additional list of arguments.

(define (list-protocol-match stack-arg-count list-args list-arg-count)
  (let ((code (template-code (closure-template *val*)))
	(total-arg-count (+ stack-arg-count list-arg-count))
	(lose (lambda ()
		(goto wrong-nargs
		      stack-arg-count list-args list-arg-count))))
    (assert (= (enum op protocol)
	       (code-vector-ref code 0)))
    (let loop ((protocol (code-vector-ref code 1))
	       (stack-space default-stack-space))
      (let ((win (lambda (skip stack-arg-count)
		   (install-*val*-closure skip)
		   (goto check-interrupts-and-go stack-space stack-arg-count))))
	(let (;; Fixed number of arguments.
	      (fixed-match (lambda (wants skip)
			     (if (= wants total-arg-count)
				 (begin
				   (push-list list-args list-arg-count)
				   (win skip total-arg-count))
				 (lose))))
	      ;; N-ary procedure.
	      (n-ary-match (lambda (wants-stack-args skip)
			     (if (<= wants-stack-args total-arg-count)
				 (begin
				   (rest-list-setup wants-stack-args
						    stack-arg-count
						    list-args
						    list-arg-count)
				   (win skip (+ wants-stack-args 1)))
				 (lose))))
	      ;; If there are > 2 args the top two are pushed on the stack.
	      ;; Then the remaining list, the total number of arguments, and
	      ;; the number on the stack are pushed on the stack.
	      (args+nargs-match (lambda (skip)
				  (let ((final-stack-arg-count
					 (if (< total-arg-count 3)
					     total-arg-count
					     (max 2 stack-arg-count))))
				    (rest-list-setup (max stack-arg-count
							  final-stack-arg-count)
						     stack-arg-count
						     list-args
						     list-arg-count)
				    (push (enter-fixnum final-stack-arg-count))
				    (push (enter-fixnum total-arg-count))
				    (win skip (+ final-stack-arg-count 3))))))
	  (cond ((= protocol nary-dispatch-protocol)
		 (if (< total-arg-count 3)
		     (let ((skip (code-vector-ref code (+ 2 total-arg-count))))
		       (if (= 0 skip)
			   (lose)
			   (begin
			     (push-list list-args list-arg-count)
			     (win skip total-arg-count))))
		     (let ((skip (code-vector-ref code 5)))
		       (if (= 0 skip)
			   (lose)
			   (args+nargs-match skip)))))
		((= protocol args+nargs-protocol)
		 (if (>= total-arg-count
			 (code-vector-ref code 2))
		     (args+nargs-match 3)
		     (lose)))
		((<= protocol maximum-stack-args)
		 (fixed-match protocol 2))
		((= protocol two-byte-nargs+list-protocol)
		 (n-ary-match (code-vector-ref16 code 2) 4))
		((= protocol two-byte-nargs-protocol)
		 (fixed-match (code-vector-ref16 code 2) 4))
		((= protocol big-stack-protocol)
		 (let ((length (code-vector-length code)))
		   (loop (code-vector-ref code (- length 3))
			 (code-vector-ref16 code (- length 2)))))
		(else
		 (error "unknown protocol" protocol)
		 (lose))))))))

; Adjusts the number of stack arguments to be WANTS-STACK-ARGS by moving
; arguments between the stack and LIST-ARGS as necessary.  Whatever is left
; of LIST-ARGS is then copied and the copy is pushed onto the stack.

(define (rest-list-setup wants-stack-args stack-arg-count list-args list-arg-count)
  (cond ((= stack-arg-count wants-stack-args)
	 (push (copy-list* list-args list-arg-count)))
	((< stack-arg-count wants-stack-args)
	 (let ((count (- wants-stack-args stack-arg-count)))
	   (push (copy-list* (push-list list-args count)
			     (- list-arg-count count)))))
	(else ; (> stack-arg-count wants-stack-args)
	 (let ((count (- stack-arg-count wants-stack-args)))
	   (push (pop-args->list* (copy-list* list-args list-arg-count)
				  count))))))

; Raise an exception, passing to it a list of the arguments on the stack and
; in LIST-ARGS.

(define (application-exception exception
			       stack-arg-count list-args list-arg-count)
  (cond ((not (vm-eq? *template* *val*))
	 (let ((args (pop-args->list* (copy-list* list-args list-arg-count)
				      stack-arg-count)))
	   (raise-exception* exception -1 *val* args))) ; no next opcode
	((< 0 *losing-opcode*)
	 (error "wrong number of arguments to exception handler"
		*losing-opcode*))
	(else
	 (error "wrong number of arguments to interrupt handler"
		(- *losing-opcode*)))))

;(define (application-exception exception stack-arg-count list-args list-arg-count)
;  (if (vm-eq? *template* *val*)
;      (error "wrong number of arguments to exception handler"
;             *losing-opcode*)
;      (let ((args (pop-args->list* (copy-list* list-args list-arg-count)
;                                   stack-arg-count)))
;        (push (enter-fixnum (current-opcode)))
;        (push (enter-fixnum exception))
;        (push *val*)
;        (push args)
;        (goto raise 2))))

; Get a two-byte number from CODE-VECTOR.

(define (code-vector-ref16 code-vector index)
  (let ((high (code-vector-ref code-vector index)))
    (adjoin-bits high
		 (code-vector-ref code-vector (+ index 1))
		 bits-used-per-byte)))

;----------------
; Manipulating lists of arguments

; Push COUNT elements from LIST onto the stack, returning whatever is left.

(define (push-list list count)
  (push list)
  (ensure-stack-space! count ensure-space)
  (let ((list (pop)))
    (do ((i count (- i 1))
	 (l list (vm-cdr l)))
	((<= i 0) l)
      (push (vm-car l)))))

; Copy LIST, which has LENGTH elements.

(define (copy-list* list length)
  (if (= length 0)
      null
      (receive (key list)
	  (ensure-space-saving-temp (* vm-pair-size length) list)
	(let ((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))))))

; Pop COUNT arguments into a list with START as the cdr.

(define (pop-args->list* start count)
  (receive (key start)
      (ensure-space-saving-temp (* vm-pair-size count) start)
    (do ((args start (vm-cons (pop) args key))
	 (count count (- count 1)))
	((= count 0)
	 args))))

;----------------
; Opcodes for the closed-compiled versions of arithmetic primitives.
; The opcode sequences used are:
;   binary-reduce1 binary-op binary-reduce2 return
; and
;   compare-reduce1 binary-comparison-op compare-reduce2 return
; The compare version quits if the comparison operator returns false.
;
; For ...-reduce1 the stack looks like:
;   arg0 arg1 ... argN rest-list N+1
; If there are two or more arguments then at least two arguments are on the
; stack.

; Turn
;   *stack* = arg0 (arg1 . more) <3
; into
;   *val* = arg1, *stack* = arg0 (arg1 .more) 1 arg0
; or turn
;   *stack* = arg0 arg1 ... argN rest-list N+1
; into
;   *val* = arg1, *stack* = false arg1 ... argN rest-list N arg0

(define-opcode binary-reduce1
  (let ((stack-nargs (extract-fixnum (stack-ref 0))))
    (if (= stack-nargs 0)
	(let ((rest-list (stack-ref 1))
	      (arg0 (stack-ref 2)))
	  (push arg0)
	  (set! *val* (vm-car rest-list)))
	(let ((arg0 (stack-ref (+ stack-nargs 1)))
	      (arg1 (stack-ref stack-nargs)))
	  (stack-set! (+ stack-nargs 1) false)
	  (stack-set! 0 (enter-fixnum (- stack-nargs 1)))
	  (push arg0)
	  (set! *val* arg1)))
    (goto continue 0)))

; Turn
;   *val* = result, *stack* = arg0 (arg1 . more) 2
; into
;   *stack* = result more 2
; or turn
;   *val* = result, *stack* = arg1 ... argN rest-list N
; into
;   *stack* = result ... argN rest-list N

(define-opcode binary-reduce2
  (let* ((stack-nargs (extract-fixnum (stack-ref 0)))
	 (delta (case stack-nargs
		  ((0)
		   (let ((rest-list (stack-ref 1)))
		     (if (vm-eq? (vm-cdr rest-list) null)
			 1
			 (begin
			   (stack-set! 1 (vm-cdr rest-list))
			   (stack-set! 2 *val*)
			   -2))))
		  ((1)
		   (let ((rest-list (stack-ref 1)))
		     (if (vm-eq? rest-list null)
			 1
			 (begin
			   (stack-set! 0 (enter-fixnum 0))
			   (stack-set! 2 *val*)
			   -2))))
		  (else
		   (stack-set! (+ stack-nargs 1) *val*)
		   -2))))
    (set! *code-pointer* (address+ *code-pointer* delta))
    (goto interpret *code-pointer*)))

(define-opcode binary-comparison-reduce2
  (if (false? *val*)
      (goto continue 0)
      (let* ((stack-nargs (extract-fixnum (stack-ref 0)))
	     (delta (case stack-nargs
		      ((0)
		       (let ((rest-list (stack-ref 1)))
			 (if (vm-eq? (vm-cdr rest-list) null)
			     1
			     (begin
			       (stack-set! 1 (vm-cdr rest-list))
			       (stack-set! 2 (vm-car rest-list))
			       -2))))
		      ((1)
		       (let ((rest-list (stack-ref 1)))
			 (if (vm-eq? rest-list null)
			     1
			     (begin
			       (stack-set! 0 (enter-fixnum 0))
			       -2))))
		      (else
		       -2))))
	(set! *code-pointer* (address+ *code-pointer* delta))
	(goto interpret *code-pointer*))))

;----------------
; Statistics stuff
;
;(define call-stats (make-vector 16 0))
;
;		(let ((i (min stack-arg-count 15)))
;		  (vector-set! call-stats i (+ 1 (vector-ref call-stats i))))
;
;(define plain-calls (make-vector 7 0))
;
;(define (add-plain-call i)
;  (vector-set! plain-calls i (+ (vector-ref plain-calls i) 1)))
;
;(define apply-calls (make-vector 7 0))
;
;(define (add-apply-call i)
;  (vector-set! apply-calls i (+ (vector-ref apply-calls i) 1)))
;
;(define (dump-call-stats)
;  (let ((out (current-output-port)))
;    (write-string "Calls:" out)
;    (do ((i 0 (+ i 1)))
;        ((= i 16))
;      (write-char #\space out)
;      (write-integer (vector-ref call-stats i) out))
;    (write-char #\newline out)
;    (write-string "Plain calls" out)
;    (write-char #\newline out)
;    (do ((i 0 (+ i 1)))
;        ((= i 7))
;      (write-char #\space out)
;      (write-string (vector-ref call-strings i) out)
;      (write-integer (vector-ref plain-calls i) out)
;      (write-char #\newline out))
;    (write-string "Apply calls" out)
;    (write-char #\newline out)
;    (do ((i 0 (+ i 1)))
;        ((= i 7))
;      (write-char #\space out)
;      (write-string (vector-ref call-strings i) out)
;      (write-integer (vector-ref apply-calls i) out)
;      (write-char #\newline out))))
;
;(define call-strings
;  '#("nary-dispatch: "
;     "args&nargs: "
;     "no-env: "
;     "two-bytes-nargs+list: "
;     "plain: "
;     "two-byte-nargs: "
;     "big-stack: "))