629 lines
21 KiB
Scheme
629 lines
21 KiB
Scheme
|
; 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: "))
|
||
|
|
|
||
|
|
|