779 lines
26 KiB
Scheme
779 lines
26 KiB
Scheme
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
|
|
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
|
|
|
|
|
; This is file cprim.scm.
|
|
|
|
;;;; Compiling primitive procedures and calls to them.
|
|
|
|
; (primitive-procedure name) => a procedure
|
|
|
|
(define-compilator 'primitive-procedure syntax-type
|
|
(lambda (node level depth cont)
|
|
(let ((name (cadr (node-form node))))
|
|
(deliver-value (sequentially
|
|
(instruction (enum op closure))
|
|
(template ((primop-closed (get-primop name)))
|
|
(name->symbol (cont-name cont)))
|
|
(instruction 0)) ; last byte of closure instruction
|
|
cont))))
|
|
|
|
; --------------------
|
|
; Direct primitives.
|
|
|
|
; The simplest kind of primitive has fixed arity, corresponds to some
|
|
; single VM instruction, and takes its arguments in the usual way (all
|
|
; on the stack).
|
|
|
|
(define (direct-compilator type opcode)
|
|
(lambda (node level depth cont)
|
|
(let ((args (cdr (node-form node))))
|
|
(sequentially (if (null? args)
|
|
empty-segment
|
|
(push-all-but-last args level depth node))
|
|
(deliver-value (instruction opcode) cont)))))
|
|
|
|
(define (direct-closed-compilator opcode)
|
|
(lambda ()
|
|
(let ((arg-specs (vector-ref opcode-arg-specs opcode)))
|
|
(sequentially (if (pair? arg-specs)
|
|
(sequentially
|
|
(instruction (enum op protocol) (car arg-specs))
|
|
(instruction (enum op pop)))
|
|
(instruction (enum op protocol) 0))
|
|
(instruction opcode)
|
|
(instruction (enum op return))))))
|
|
|
|
(define (nargs->domain nargs)
|
|
(do ((nargs nargs (- nargs 1))
|
|
(l '() (cons value-type l)))
|
|
((= nargs 0) (make-some-values-type l))))
|
|
|
|
(define (get-primop-type id arg-count)
|
|
(or (any (lambda (foo)
|
|
(if (if (pair? (car foo))
|
|
(memq id (car foo))
|
|
(eq? id (car foo)))
|
|
(cadr foo)
|
|
#f))
|
|
primop-types)
|
|
(procedure-type (nargs->domain arg-count)
|
|
value-type
|
|
#t)))
|
|
|
|
; Types for various primops.
|
|
|
|
(define primop-types
|
|
`((with-continuation
|
|
,(proc (escape-type (proc () any-values-type #f))
|
|
any-arguments-type))
|
|
(eq?
|
|
,(proc (value-type value-type) boolean-type))
|
|
((number? integer? rational? real? complex? char? eof-object? port?)
|
|
,(proc (value-type) boolean-type))
|
|
(exact?
|
|
,(proc (number-type) boolean-type))
|
|
(exact->inexact
|
|
,(proc (exact-type) inexact-type))
|
|
(inexact->exact
|
|
,(proc (inexact-type) exact-type))
|
|
((exp log sin cos tan asin acos sqrt)
|
|
,(proc (number-type) number-type))
|
|
((atan)
|
|
,(proc (number-type number-type) number-type))
|
|
((floor)
|
|
,(proc (real-type) integer-type))
|
|
((real-part imag-part angle magnitude)
|
|
,(proc (complex-type) real-type))
|
|
((numerator denominator)
|
|
,(proc (rational-type) integer-type))
|
|
((make-polar make-rectangular)
|
|
,(proc (real-type real-type) complex-type))
|
|
((quotient remainder)
|
|
,(proc (integer-type integer-type) integer-type))
|
|
((bitwise-not)
|
|
,(proc (exact-integer-type) exact-integer-type))
|
|
((arithmetic-shift)
|
|
,(proc (exact-integer-type exact-integer-type)
|
|
exact-integer-type))
|
|
((char=? char<?)
|
|
,(proc (char-type char-type) boolean-type))
|
|
(char->ascii
|
|
,(proc (char-type) exact-integer-type))
|
|
(ascii->char
|
|
,(proc (exact-integer-type) char-type))
|
|
(string=?
|
|
,(proc (string-type string-type) boolean-type))
|
|
(open-channel
|
|
;; Can return #f
|
|
,(proc (string-type exact-integer-type) value-type))
|
|
(cons
|
|
,(proc (value-type value-type) pair-type))
|
|
(intern
|
|
,(proc (string-type) symbol-type))))
|
|
|
|
; Can't do I/O until the meta-types interface exports input-port-type and
|
|
; output-port-type.
|
|
|
|
; Define all the primitives that correspond to opcodes in the obvious way.
|
|
|
|
(do ((opcode 0 (+ opcode 1)))
|
|
((= opcode op-count))
|
|
(let ((arg-specs (vector-ref opcode-arg-specs opcode))
|
|
(name (enumerand->name opcode op)))
|
|
(cond ((memq name '(call-external-value return-from-interrupt return)))
|
|
((null? arg-specs)
|
|
(let ((type (proc () value-type)))
|
|
(define-compiler-primitive name type
|
|
(direct-compilator type opcode)
|
|
(direct-closed-compilator opcode))))
|
|
((not (number? (car arg-specs))))
|
|
((memq name '(+ * - / = < > <= >=
|
|
bitwise-ior bitwise-xor bitwise-and
|
|
make-string closed-apply)))
|
|
(else
|
|
(let ((type (get-primop-type name (car arg-specs))))
|
|
(define-compiler-primitive name type
|
|
(direct-compilator type opcode)
|
|
(direct-closed-compilator opcode)))))))
|
|
|
|
; --------------------
|
|
; Simple primitives are executed using a fixed instruction or
|
|
; instruction sequence.
|
|
|
|
(define (define-simple-primitive name type segment)
|
|
(let ((winner? (fixed-arity-procedure-type? type)))
|
|
(let ((nargs (if winner?
|
|
(procedure-type-arity type)
|
|
(error "n-ary simple primitive?!" name type))))
|
|
(define-compiler-primitive name type
|
|
(simple-compilator segment)
|
|
(simple-closed-compilator nargs segment)))))
|
|
|
|
(define (simple-compilator segment)
|
|
(lambda (node level depth cont)
|
|
(let ((args (cdr (node-form node))))
|
|
(sequentially (if (null? args)
|
|
empty-segment
|
|
(push-all-but-last args level depth node))
|
|
(deliver-value segment cont)))))
|
|
|
|
(define (simple-closed-compilator nargs segment)
|
|
(lambda ()
|
|
(sequentially (instruction (enum op protocol) nargs)
|
|
(instruction (enum op pop))
|
|
segment
|
|
(instruction (enum op return)))))
|
|
|
|
(define (symbol-append . syms)
|
|
(string->symbol (apply string-append
|
|
(map symbol->string syms))))
|
|
|
|
(define (define-stob-predicate name stob-name)
|
|
(define-simple-primitive name
|
|
(proc (value-type) boolean-type)
|
|
(instruction (enum op stored-object-has-type?)
|
|
(name->enumerand stob-name stob))))
|
|
|
|
(define-stob-predicate 'byte-vector? 'byte-vector)
|
|
(define-stob-predicate 'double? 'double)
|
|
(define-stob-predicate 'string? 'string)
|
|
|
|
; Making doubles
|
|
|
|
(let ((:value (sexp->type ':value #t))
|
|
(:double (sexp->type ':double #t)))
|
|
(define-simple-primitive 'make-double
|
|
(proc () :double)
|
|
(sequentially
|
|
(instruction-with-literal (enum op literal) 0)
|
|
(instruction (enum op push))
|
|
(instruction-with-literal (enum op literal) 0)
|
|
(instruction (enum op make-stored-object) 2 (enum stob double)))))
|
|
|
|
; Define primitives for record-like stored objects (e.g. pairs).
|
|
|
|
(define (define-data-struct-primitives name predicate maker . slots)
|
|
(let* ((def-prim (lambda (name type op . stuff)
|
|
(define-simple-primitive name type
|
|
(apply instruction (cons op stuff)))))
|
|
(type-byte (name->enumerand name stob))
|
|
(type (sexp->type (symbol-append ': name) #t)))
|
|
(define-stob-predicate predicate name)
|
|
(if maker
|
|
(def-prim maker
|
|
(procedure-type (nargs->domain (length slots)) type #t)
|
|
(enum op make-stored-object)
|
|
(length slots)
|
|
type-byte))
|
|
(do ((i 0 (+ i 1))
|
|
(slots slots (cdr slots)))
|
|
((null? slots))
|
|
(let ((slot (car slots)))
|
|
(if (car slot)
|
|
(def-prim (car slot)
|
|
(proc (type) value-type)
|
|
(enum op stored-object-ref) type-byte i))
|
|
(if (not (null? (cdr slot)))
|
|
(def-prim (cadr slot)
|
|
(proc (type value-type) unspecific-type)
|
|
(enum op stored-object-set!) type-byte i))))))
|
|
|
|
(for-each (lambda (stuff)
|
|
(apply define-data-struct-primitives stuff))
|
|
stob-data)
|
|
|
|
; Define primitives for vector-like stored objects.
|
|
|
|
(define (define-vector-primitives name element-type make length ref set!)
|
|
(let* ((type-byte (name->enumerand name stob))
|
|
(def-prim (lambda (name type op)
|
|
(define-simple-primitive name type
|
|
(instruction op type-byte))))
|
|
(type (sexp->type (symbol-append ': name) #t)))
|
|
(define-stob-predicate (symbol-append name '?) name)
|
|
(if (not (eq? name 'vector)) ; 2nd arg to make-vector is optional
|
|
(def-prim (symbol-append 'make- name)
|
|
(proc (exact-integer-type element-type) type)
|
|
make))
|
|
(def-prim (symbol-append name '- 'length)
|
|
(proc (type) exact-integer-type)
|
|
length)
|
|
(def-prim (symbol-append name '- 'ref)
|
|
(proc (type exact-integer-type) element-type)
|
|
ref)
|
|
(def-prim (symbol-append name '- 'set!)
|
|
(proc (type exact-integer-type element-type) unspecific-type)
|
|
set!)))
|
|
|
|
(for-each (lambda (name)
|
|
(define-vector-primitives name value-type
|
|
(enum op make-vector-object)
|
|
(enum op stored-object-length)
|
|
(enum op stored-object-indexed-ref)
|
|
(enum op stored-object-indexed-set!)))
|
|
'(vector record continuation extended-number template))
|
|
|
|
; SIGNAL-CONDITION is the same as TRAP.
|
|
|
|
(define-simple-primitive 'signal-condition (proc (pair-type) unspecific-type)
|
|
(instruction (enum op trap)))
|
|
|
|
|
|
; (primitive-catch (lambda (cont) ...))
|
|
|
|
(define-compiler-primitive 'primitive-catch
|
|
(proc ((proc (escape-type) any-values-type #f)) any-values-type)
|
|
;; (primitive-catch (lambda (cont) ...))
|
|
(lambda (node level depth cont)
|
|
(let* ((exp (node-form node))
|
|
(args (cdr exp)))
|
|
(maybe-push-continuation
|
|
(sequentially (instruction (enum op current-cont))
|
|
(instruction (enum op push))
|
|
;; If lambda exp, should do compile-lambda-code to
|
|
;; avoid consing closure...
|
|
(compile (car args) level 1 (fall-through-cont node 1))
|
|
(instruction (enum op call) 1))
|
|
0
|
|
cont)))
|
|
(lambda ()
|
|
(sequentially (instruction (enum op protocol) 1)
|
|
(instruction (enum op make-env) ;Seems unavoidable.
|
|
(high-byte 1)
|
|
(low-byte 1))
|
|
(instruction (enum op current-cont))
|
|
(instruction (enum op push))
|
|
(instruction (enum op local0) 1)
|
|
(instruction (enum op call) 1))))
|
|
|
|
; (call-with-values (lambda () ...producer...)
|
|
; (lambda args ...consumer...))
|
|
|
|
(define-compiler-primitive 'call-with-values
|
|
(proc ((proc () any-values-type #f)
|
|
any-procedure-type)
|
|
any-values-type)
|
|
(lambda (node level depth cont)
|
|
(let ((args (cdr (node-form node))))
|
|
(let ((producer (car args))
|
|
(consumer (cadr args)))
|
|
(maybe-push-continuation
|
|
(sequentially (compile consumer level 0 (fall-through-cont node 2))
|
|
(instruction (enum op push))
|
|
(maybe-push-continuation ; nothing maybe about it
|
|
(compile-call (make-node operator/call `(,producer))
|
|
level 0
|
|
(return-cont #f))
|
|
1
|
|
(fall-through-cont #f 0))
|
|
(instruction (enum op call-with-values)))
|
|
depth
|
|
cont))))
|
|
(lambda ()
|
|
;; producer and consumer on stack
|
|
(let ((label (make-label)))
|
|
(sequentially (instruction (enum op protocol) 2)
|
|
(instruction (enum op make-env)
|
|
(high-byte 2)
|
|
(low-byte 2))
|
|
(instruction (enum op local0) 1) ;consumer
|
|
(instruction (enum op push))
|
|
(instruction-using-label (enum op make-cont) label 1)
|
|
(instruction (enum op local0) 2) ;producer
|
|
(instruction (enum op call) 0)
|
|
(attach-label label
|
|
(instruction (enum op call-with-values)))))))
|
|
|
|
|
|
; --------------------
|
|
; Variable-arity primitives
|
|
|
|
(define (define-n-ary-compiler-primitive name result-type min-nargs
|
|
compilator closed)
|
|
(define-compiler-primitive name
|
|
(if result-type
|
|
(procedure-type any-arguments-type result-type #f)
|
|
#f)
|
|
(if compilator
|
|
(n-ary-primitive-compilator name min-nargs compilator)
|
|
compile-unknown-call)
|
|
closed))
|
|
|
|
(define (n-ary-primitive-compilator name min-nargs compilator)
|
|
(lambda (node level depth cont)
|
|
(let ((exp (node-form node)))
|
|
(if (>= (length (cdr exp)) min-nargs)
|
|
(compilator node level depth cont)
|
|
(begin (warn "too few arguments to primitive"
|
|
(schemify node))
|
|
(compile-unknown-call node level depth cont))))))
|
|
|
|
|
|
; APPLY wants the arguments on the stack, with the final list on top, and the
|
|
; procedure in *VAL*.
|
|
|
|
(define-compiler-primitive 'apply
|
|
(proc (any-procedure-type &rest value-type) any-values-type)
|
|
(n-ary-primitive-compilator 'apply 2
|
|
(lambda (node level depth cont)
|
|
(let ((exp (node-form node))) ; (apply proc arg1 arg2 arg3 rest)
|
|
(let* ((proc+args+rest (cdr exp))
|
|
(rest+args ; (rest arg3 arg2 arg1)
|
|
(reverse (cdr proc+args+rest)))
|
|
(args+rest+proc ; (arg1 arg2 arg3 rest proc)
|
|
(reverse (cons (car proc+args+rest) rest+args)))
|
|
(stack-nargs (length (cdr rest+args))))
|
|
(maybe-push-continuation
|
|
(sequentially (push-all-but-last args+rest+proc level 0 #f)
|
|
;; Operand is number of non-final arguments
|
|
(instruction (enum op apply)
|
|
(high-byte stack-nargs)
|
|
(low-byte stack-nargs)))
|
|
depth
|
|
cont)))))
|
|
(lambda ()
|
|
(sequentially (instruction (enum op protocol) args+nargs-protocol 2)
|
|
(instruction (enum op closed-apply)))))
|
|
|
|
; (values value1 value2 ...)
|
|
|
|
(define-n-ary-compiler-primitive 'values #f 0
|
|
(lambda (node level depth cont)
|
|
(let* ((args (cdr (node-form node)))
|
|
(nargs (length args)))
|
|
(if (= 1 nargs)
|
|
(compile (car args) level depth cont) ;+++
|
|
(maybe-push-continuation (sequentially (push-arguments node level 0)
|
|
(instruction (enum op values)
|
|
(high-byte nargs)
|
|
(low-byte nargs)))
|
|
depth
|
|
cont))))
|
|
(lambda ()
|
|
(sequentially (instruction (enum op protocol) args+nargs-protocol 0)
|
|
(instruction (enum op closed-values)))))
|
|
|
|
|
|
; (error message irritant1 irritant2)
|
|
; => (trap (cons 'error (cons message (cons irritant1 (cons irritant2 '())))))
|
|
|
|
(let ((cons-instruction
|
|
(instruction (enum op make-stored-object) 2 (enum stob pair))))
|
|
|
|
(define-n-ary-compiler-primitive 'error error-type 1
|
|
(lambda (node level depth cont)
|
|
(let ((exp (node-form node)))
|
|
(let ((args (cdr exp)))
|
|
(sequentially (instruction-with-literal (enum op literal) 'error)
|
|
(instruction (enum op push))
|
|
(push-arguments node level (+ depth 1))
|
|
(instruction-with-literal (enum op literal) '())
|
|
(apply sequentially
|
|
(map (lambda (arg) cons-instruction) args))
|
|
cons-instruction
|
|
(deliver-value (instruction (enum op trap)) cont)))))
|
|
(lambda ()
|
|
; stack at start is: irritants message
|
|
(sequentially (instruction (enum op protocol)
|
|
two-byte-nargs+list-protocol
|
|
0 ; (high-byte 1)
|
|
1) ; (low-byte 1)
|
|
(instruction (enum op pop)) ; list into *val*
|
|
cons-instruction
|
|
(instruction (enum op push))
|
|
(instruction-with-literal (enum op literal) 'error)
|
|
(instruction (enum op push))
|
|
(instruction (enum op stack-ref) 1)
|
|
cons-instruction
|
|
(instruction (enum op trap))
|
|
(instruction (enum op return))))))
|
|
|
|
|
|
; (call-external-value external-routine arg ...)
|
|
|
|
(define-n-ary-compiler-primitive 'call-external-value value-type 1
|
|
#f ;Could be done
|
|
(lambda ()
|
|
(sequentially (instruction (enum op protocol) args+nargs-protocol 1)
|
|
(instruction (enum op call-external-value))
|
|
(instruction (enum op return)))))
|
|
|
|
(let ((n-ary-constructor
|
|
(lambda (name type type-byte)
|
|
(define-n-ary-compiler-primitive name type 0
|
|
(lambda (node level depth cont)
|
|
(let ((args (cdr (node-form node))))
|
|
(sequentially (if (null? args)
|
|
empty-segment
|
|
(push-all-but-last args level depth node))
|
|
(deliver-value
|
|
(instruction (enum op make-stored-object)
|
|
(length args)
|
|
type-byte)
|
|
cont))))
|
|
(lambda ()
|
|
(sequentially
|
|
(instruction (enum op protocol) args+nargs-protocol 0)
|
|
(instruction (enum op closed-make-stored-object) type-byte)
|
|
(instruction (enum op return))))))))
|
|
(n-ary-constructor 'vector vector-type (enum stob vector))
|
|
(n-ary-constructor 'record #f (enum stob record)))
|
|
|
|
; READ-CHAR, PEEK-CHAR and WRITE-CHAR
|
|
|
|
(let ((define-char-io
|
|
(lambda (id opcode type)
|
|
(define-compiler-primitive id
|
|
type
|
|
(lambda (node level depth cont)
|
|
(if (node-ref node 'type-error)
|
|
(compile-unknown-call node level depth cont)
|
|
(let ((args (cdr (node-form node))))
|
|
(if (null? args)
|
|
(deliver-value (instruction opcode 1) cont)
|
|
(sequentially
|
|
(push-all-but-last args level depth node)
|
|
(deliver-value (instruction opcode 0) cont))))))
|
|
(lambda ()
|
|
(make-dispatch-protocol
|
|
; Zero arguments
|
|
(sequentially
|
|
(instruction opcode 1)
|
|
(instruction (enum op return)))
|
|
; One argument
|
|
(sequentially
|
|
(instruction (enum op pop))
|
|
(instruction opcode 0)
|
|
(instruction (enum op return)))
|
|
empty-segment
|
|
empty-segment))))))
|
|
(define-char-io 'read-char
|
|
(enum op read-char)
|
|
(proc (&opt value-type) value-type))
|
|
(define-char-io 'peek-char
|
|
(enum op peek-char)
|
|
(proc (&opt value-type) value-type)))
|
|
|
|
(let ((define-char-io
|
|
(lambda (id opcode type)
|
|
(define-compiler-primitive id
|
|
type
|
|
(lambda (node level depth cont)
|
|
(if (node-ref node 'type-error)
|
|
(compile-unknown-call node level depth cont)
|
|
(let ((args (cdr (node-form node))))
|
|
(sequentially
|
|
(push-all-but-last args level depth node)
|
|
(if (null? (cdr args))
|
|
(deliver-value (instruction opcode 1) cont)
|
|
(sequentially
|
|
(deliver-value (instruction opcode 0) cont)))))))
|
|
(lambda ()
|
|
(make-dispatch-protocol
|
|
empty-segment
|
|
; One argument
|
|
(sequentially
|
|
(instruction (enum op pop))
|
|
(instruction opcode 1)
|
|
(instruction (enum op return)))
|
|
; Two arguments
|
|
(sequentially
|
|
(instruction (enum op pop))
|
|
(instruction opcode 0)
|
|
(instruction (enum op return)))
|
|
empty-segment))))))
|
|
(define-char-io 'write-char
|
|
(enum op write-char)
|
|
(proc (char-type &opt value-type) unspecific-type)))
|
|
|
|
; Timings in 0.47 to figure out how to handle the optional ports.
|
|
;
|
|
; reading 10**6 characters (no buffer underflow)
|
|
; empty loop time: 3.44 seconds
|
|
; read-char time: 3.68 seconds ; special primitive, exceptions
|
|
; xread-char time: 9.04 seconds ; special primitive, no exceptions
|
|
; xxread-char time: 14.05 seconds ; no special primitive
|
|
; Currently, looping through a 10**6 character file takes 1.51 seconds or
|
|
; 2.50 seconds if you count the number of characters.
|
|
|
|
;----------------
|
|
; Variable-arity arithmetic primitives.
|
|
|
|
; +, *, bitwise-... take any number of arguments.
|
|
|
|
(let ((define+*
|
|
(lambda (id opcode identity type)
|
|
(define-compiler-primitive id
|
|
(proc (&rest type) type)
|
|
(lambda (node level depth cont)
|
|
(if (node-ref node 'type-error)
|
|
(compile-unknown-call node level depth cont)
|
|
(let ((args (cdr (node-form node))))
|
|
(cond ((null? args)
|
|
(deliver-value
|
|
(instruction-with-literal (enum op literal)
|
|
identity)
|
|
cont))
|
|
((null? (cdr args))
|
|
(call-on-arg-and-id opcode identity (car args)
|
|
node level depth cont))
|
|
(else
|
|
(call-on-args opcode args node level depth cont))))))
|
|
(lambda ()
|
|
(make-dispatch-protocol
|
|
; No arguments
|
|
(sequentially
|
|
(instruction-with-literal (enum op literal) identity)
|
|
(instruction (enum op return)))
|
|
; One argument
|
|
(sequentially
|
|
(instruction-with-literal (enum op literal) identity)
|
|
(instruction opcode)
|
|
(instruction (enum op return)))
|
|
; Two arguments
|
|
(sequentially
|
|
(instruction (enum op pop))
|
|
(instruction opcode)
|
|
(instruction (enum op return)))
|
|
; More than two arguments
|
|
(sequentially
|
|
(instruction (enum op pop)) ; pop off nargs
|
|
(instruction (enum op binary-reduce1))
|
|
(instruction opcode)
|
|
(instruction (enum op binary-reduce2))
|
|
(instruction (enum op return)))))))))
|
|
(define+* '+ (enum op +) 0 number-type)
|
|
(define+* '* (enum op *) 1 number-type)
|
|
(define+* 'bitwise-ior (enum op bitwise-ior) 0 exact-integer-type)
|
|
(define+* 'bitwise-xor (enum op bitwise-xor) 0 exact-integer-type)
|
|
(define+* 'bitwise-and (enum op bitwise-and) -1 exact-integer-type))
|
|
|
|
; = and < and so forth take two or more arguments.
|
|
|
|
(let ((define=<
|
|
(lambda (id opcode)
|
|
(define-compiler-primitive id
|
|
(proc (real-type real-type &rest real-type) boolean-type)
|
|
(lambda (node level depth cont)
|
|
(if (node-ref node 'type-error)
|
|
(compile-unknown-call node level depth cont)
|
|
(let ((args (cdr (node-form node))))
|
|
(if (= (length args) 2)
|
|
(call-on-args opcode args node level depth cont)
|
|
(compile-unknown-call node level depth cont)))))
|
|
(lambda ()
|
|
(make-dispatch-protocol
|
|
empty-segment
|
|
empty-segment
|
|
; Two arguments
|
|
(sequentially
|
|
(instruction (enum op pop)) ; get first argument
|
|
(instruction opcode)
|
|
(instruction (enum op return)))
|
|
; More than two arguments
|
|
(sequentially
|
|
(instruction (enum op pop))
|
|
(instruction (enum op binary-reduce1))
|
|
(instruction opcode)
|
|
(instruction (enum op binary-comparison-reduce2))
|
|
(instruction (enum op return)))))))))
|
|
(define=< '= (enum op =))
|
|
(define=< '< (enum op <))
|
|
(define=< '> (enum op >))
|
|
(define=< '<= (enum op <=))
|
|
(define=< '>= (enum op >=)))
|
|
|
|
; Returns code to apply OPCODE to IDENTITY and ARGUMENT.
|
|
|
|
(define (call-on-arg-and-id opcode identity argument node level depth cont)
|
|
(sequentially (instruction-with-literal (enum op literal) identity)
|
|
(instruction (enum op push))
|
|
(compile argument level (+ depth 1) (fall-through-cont node 1))
|
|
(deliver-value (instruction opcode) cont)))
|
|
|
|
; Returns code to redue ARGS using OPCODE.
|
|
|
|
(define (call-on-args opcode args node level depth cont)
|
|
(let ((do-arg (lambda (arg index)
|
|
(compile arg
|
|
level
|
|
(if (= index 1) depth (+ depth 1))
|
|
(fall-through-cont node index)))))
|
|
(let loop ((args (cdr args)) (i 2) (code (do-arg (car args) 1)))
|
|
(if (null? args)
|
|
(deliver-value code cont)
|
|
(loop (cdr args)
|
|
(+ i 1)
|
|
(sequentially code
|
|
(instruction (enum op push))
|
|
(do-arg (car args) i)
|
|
(instruction opcode)))))))
|
|
|
|
(define op/unspecific (get-operator 'unspecific))
|
|
(define op/literal (get-operator 'literal))
|
|
|
|
; -, and / take one or two arguments.
|
|
|
|
(let ((define-one-or-two
|
|
(lambda (id opcode default-arg)
|
|
(define-compiler-primitive id
|
|
(proc (number-type &opt number-type) number-type)
|
|
(lambda (node level depth cont)
|
|
(if (node-ref node 'type-error)
|
|
(compile-unknown-call node level depth cont)
|
|
(let* ((args (cdr (node-form node)))
|
|
(args (if (null? (cdr args))
|
|
(list (make-node op/literal default-arg)
|
|
(car args))
|
|
args)))
|
|
(sequentially
|
|
(push-all-but-last args level depth node)
|
|
(deliver-value (instruction opcode) cont)))))
|
|
(lambda ()
|
|
(make-dispatch-protocol
|
|
empty-segment
|
|
; One argument
|
|
(sequentially
|
|
(instruction-with-literal (enum op literal) default-arg)
|
|
(instruction (enum op push))
|
|
(instruction (enum op stack-ref) 1)
|
|
(instruction opcode)
|
|
(instruction (enum op return)))
|
|
; Two arguments
|
|
(sequentially
|
|
(instruction (enum op pop))
|
|
(instruction opcode)
|
|
(instruction (enum op return)))
|
|
empty-segment))))))
|
|
(define-one-or-two '- (enum op -) 0)
|
|
(define-one-or-two '/ (enum op /) 1))
|
|
|
|
; make-vector and make-string take one or two arguments.
|
|
|
|
(let ((define-one-or-two
|
|
(lambda (id op-segment default-arg default-arg-segment type)
|
|
(define-compiler-primitive id
|
|
type
|
|
(lambda (node level depth cont)
|
|
(if (node-ref node 'type-error)
|
|
(compile-unknown-call node level depth cont)
|
|
(let* ((args (cdr (node-form node)))
|
|
(args (if (null? (cdr args))
|
|
(list (car args) default-arg)
|
|
args)))
|
|
(sequentially
|
|
(push-all-but-last args level depth node)
|
|
(deliver-value op-segment cont)))))
|
|
(lambda ()
|
|
(make-dispatch-protocol
|
|
empty-segment
|
|
; One argument
|
|
(sequentially
|
|
default-arg-segment
|
|
op-segment
|
|
(instruction (enum op return)))
|
|
; Two arguments
|
|
(sequentially
|
|
(instruction (enum op pop))
|
|
op-segment
|
|
(instruction (enum op return)))
|
|
empty-segment))))))
|
|
(define-one-or-two 'make-vector
|
|
(instruction (enum op make-vector-object) (enum stob vector))
|
|
(make-node op/unspecific '(unspecific))
|
|
(instruction (enum op unspecific))
|
|
(proc (number-type &opt value-type) vector-type))
|
|
(define-one-or-two 'make-string
|
|
(instruction (enum op make-string))
|
|
(make-node op/literal #\?)
|
|
(instruction-with-literal (enum op literal) #\?)
|
|
(proc (number-type &opt char-type) string-type)))
|
|
|
|
; --------------------
|
|
; Utilities
|
|
|
|
(define (push-all-but-last args level depth source-info)
|
|
(let recur ((args args) (depth depth) (i 1))
|
|
(let ((first-code
|
|
(compile (car args) level depth (fall-through-cont source-info i))))
|
|
(if (null? (cdr args))
|
|
first-code
|
|
(sequentially first-code
|
|
(instruction (enum op push))
|
|
(recur (cdr args) (+ depth 1) (+ i 1)))))))
|
|
|
|
; Building primitives that use the computed-goto provided by the
|
|
; protocol dispatcher.
|
|
|
|
(define dispatch-protocol-size
|
|
(segment-size (instruction (enum op protocol) nary-dispatch-protocol
|
|
0 0 0 0)))
|
|
|
|
(define (make-dispatch-protocol zero-args one-arg two-args three-plus-args)
|
|
(sequentially
|
|
(instruction (enum op protocol) nary-dispatch-protocol
|
|
(if (= 0 (segment-size zero-args))
|
|
0
|
|
dispatch-protocol-size)
|
|
(if (= 0 (segment-size one-arg))
|
|
0
|
|
(+ dispatch-protocol-size
|
|
(segment-size zero-args)))
|
|
(if (= 0 (segment-size two-args))
|
|
0
|
|
(+ dispatch-protocol-size
|
|
(segment-size zero-args)
|
|
(segment-size one-arg)))
|
|
(if (= 0 (segment-size three-plus-args))
|
|
0
|
|
(+ dispatch-protocol-size
|
|
(segment-size zero-args)
|
|
(segment-size one-arg)
|
|
(segment-size two-args))))
|
|
zero-args
|
|
one-arg
|
|
two-args
|
|
three-plus-args))
|
|
|