scsh-0.6/scheme/bcomp/comp-prim.scm

779 lines
26 KiB
Scheme
Raw Normal View History

1999-09-14 08:45:02 -04:00
; -*- 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))