scsh-0.5/vm/prim.scm

674 lines
20 KiB
Scheme
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; This is file prim.scm.
; Requires DEFINE-PRIMITIVE macro.
;;;; VM data manipulation primitives
; Input checking and coercion
(define (input-type pred coercer) ;Alonzo wins
(lambda (f) (f pred coercer)))
(define (input-type-predicate type) (type (lambda (x y) y x)))
(define (input-type-coercion type) (type (lambda (x y) x y)))
(define (no-coercion x) x)
(define any-> (input-type (lambda (x) x #t) no-coercion))
(define fixnum-> (input-type fixnum? extract-fixnum))
(define char-> (input-type vm-char? extract-char))
(define vm-char-> (input-type vm-char? no-coercion))
(define boolean-> (input-type vm-boolean? extract-boolean))
(define location-> (input-type location? no-coercion))
(define string-> (input-type vm-string? no-coercion))
(define vector-> (input-type vm-vector? no-coercion))
(define code-vector-> (input-type code-vector? no-coercion))
; Output coercion
(define (return val)
(set! *val* val)
(goto interpret))
(define return-any return)
(define (return-boolean x)
(goto return (enter-boolean x)))
(define (return-fixnum x)
(goto return (enter-fixnum x)))
(define (return-char x)
(goto return (enter-char x)))
(define (return-unspecific x)
x ;ignored
(goto return unspecific))
; Scalar primitives
(define-primitive eq? (any-> any->) vm-eq? return-boolean)
; Rudimentary generic arithmetic. Incomplete and confusing.
; How to modularize for VM's like Maclisp that have generic arithmetic
; built-in?
; These predicates are used to characterize the numeric representations that
; are implemented in the VM.
(define primitive-number? fixnum?)
(define primitive-real? fixnum?)
(define primitive-integer? fixnum?)
(define number-> (input-type primitive-number? no-coercion))
(define real-> (input-type primitive-real? no-coercion))
(define integer-> (input-type primitive-integer? no-coercion))
(define-primitive number? (any->)
(lambda (x)
(or (fixnum? x)
(extended-number? x)))
return-boolean)
(define-syntax define-numeric-predicate
(syntax-rules ()
((define-numeric-predicate op)
(define-primitive op
(any->)
(lambda (n)
(cond ((fixnum? n)
(goto return (enter-boolean #t)))
((extended-number? n)
(goto raise-exception1 0 n))
(else
(goto return (enter-boolean #f)))))))))
(define-numeric-predicate integer?)
(define-numeric-predicate rational?)
(define-numeric-predicate real?)
(define-numeric-predicate complex?)
; These primitives have a simple answer in the case of fixnums; for all other
; they punt to the run-time system.
(define-primitive exact? (number->) (lambda (n) #t) return-boolean)
(define-primitive real-part (number->) (lambda (n) (goto return n)))
(define-primitive imag-part (number->) (lambda (n)
(goto return (enter-fixnum 0))))
(define-primitive floor (number->) (lambda (n) (goto return n)))
(define-primitive numerator (number->) (lambda (n) (goto return n)))
(define-primitive denominator (number->) (lambda (n)
(goto return (enter-fixnum 1))))
(define-primitive angle (number->) (lambda (n)
(if (>= n 0)
(goto return (enter-fixnum 0))
(goto raise-exception1 0 n))))
; beware of (abs least-fixnum)
(define-primitive magnitude (number->)
(lambda (n)
(abs-carefully n
return
(lambda (n)
(goto raise-exception1 0 n)))))
; These primitives all just raise an exception and let the run-time system do
; the work.
(define-syntax define-punt-primitive
(syntax-rules ()
((define-punt-primitive op)
(define-primitive op (number->)
(lambda (n) (goto raise-exception1 0 n))))))
(define-punt-primitive exact->inexact)
(define-punt-primitive inexact->exact)
(define-punt-primitive exp)
(define-punt-primitive log)
(define-punt-primitive sin)
(define-punt-primitive cos)
(define-punt-primitive tan)
(define-punt-primitive asin)
(define-punt-primitive acos)
(define-punt-primitive sqrt)
(define-syntax define-punt2-primitive
(syntax-rules ()
((define-punt2-primitive op)
(define-primitive op (number-> number->)
(lambda (n m) (goto raise-exception2 0 n m))))))
(define-punt2-primitive atan)
(define-punt2-primitive make-polar)
(define-punt2-primitive make-rectangular)
(define (arithmetic-overflow x y)
(goto raise-exception2 0 x y))
(define (arith op)
(lambda (x y)
(goto op x y return arithmetic-overflow)))
(define-primitive + (number-> number->) (arith add-carefully))
(define-primitive - (number-> number->) (arith subtract-carefully))
(define-primitive * (number-> number->) (arith multiply-carefully))
(define-primitive / (number-> number->) (arith divide-carefully))
(define-primitive quotient (integer-> integer->) (arith quotient-carefully))
(define-primitive remainder (integer-> integer->) (arith remainder-carefully))
(define-primitive = (number-> number->) vm-= return-boolean)
(define-primitive < (real-> real->) vm-< return-boolean)
(define-primitive arithmetic-shift (number-> number->)
(arith shift-carefully))
(define-primitive char? (any->) vm-char? return-boolean)
(define-primitive char=? (vm-char-> vm-char->) vm-char=? return-boolean)
(define-primitive char<? (vm-char-> vm-char->) vm-char<? return-boolean)
(define-primitive char->ascii (char->) char->ascii return-fixnum)
(define-primitive ascii->char
(fixnum->)
(lambda (x)
(if (or (> x 255) (< x 0))
(goto raise-exception1 0 (enter-fixnum x))
(goto return (enter-char (ascii->char x))))))
(define-primitive eof-object?
(any->)
(lambda (x) (vm-eq? x eof-object))
return-boolean)
(define-primitive bitwise-not (fixnum->) bitwise-not return-fixnum)
(define-primitive bitwise-and (fixnum-> fixnum->) bitwise-and return-fixnum)
(define-primitive bitwise-ior (fixnum-> fixnum->) bitwise-ior return-fixnum)
(define-primitive bitwise-xor (fixnum-> fixnum->) bitwise-xor return-fixnum)
(define-primitive stored-object-has-type?
(any->)
(lambda (x)
(stob-of-type? x (next-byte)))
return-boolean)
(define-primitive stored-object-length
(any->)
(lambda (stob)
(let ((type (next-byte)))
(if (stob-of-type? stob type)
(goto return-fixnum (d-vector-length stob))
(goto raise-exception2 1 stob (enter-fixnum type))))))
; Fixed sized objects
(define-primitive stored-object-ref
(any->)
(lambda (stob)
(let* ((type (next-byte))
(offset (next-byte)))
(if (stob-of-type? stob type)
(goto return (d-vector-ref stob offset))
(goto raise-exception3 2
stob
(enter-fixnum type)
(enter-fixnum offset))))))
(define-primitive stored-object-set!
(any-> any->)
(lambda (stob value)
(let* ((type (next-byte))
(offset (next-byte)))
(cond ((and (stob-of-type? stob type)
(not (immutable? stob)))
(d-vector-set! stob offset value)
(goto return unspecific))
(else
(goto raise-exception4 2
stob
(enter-fixnum type)
(enter-fixnum offset)
value))))))
; Indexed objects
(define-primitive stored-object-indexed-ref
(any-> fixnum->)
(lambda (stob index)
(let ((type (next-byte)))
(if (and (stob-of-type? stob type)
(valid-index? index (d-vector-length stob)))
(goto return (d-vector-ref stob index))
(goto raise-exception3 1
stob (enter-fixnum type) (enter-fixnum index))))))
(define-primitive stored-object-indexed-set! (any-> fixnum-> any->)
(lambda (stob index value)
(let ((type (next-byte)))
(cond ((and (stob-of-type? stob type)
(valid-index? index (d-vector-length stob))
(not (immutable? stob)))
(d-vector-set! stob index value)
(goto return unspecific))
(else
(goto raise-exception4 1
stob
(enter-fixnum type)
(enter-fixnum index)
value))))))
; Code-vectors
(define-primitive code-vector-length
(code-vector->)
(lambda (code-vector)
(goto return-fixnum (code-vector-length code-vector))))
(define-primitive code-vector-ref
(code-vector-> fixnum->)
(lambda (code-vector index)
(if (valid-index? index (code-vector-length code-vector))
(goto return-fixnum (code-vector-ref code-vector index))
(goto raise-exception2 0 code-vector (enter-fixnum index)))))
(define-primitive code-vector-set!
(code-vector-> fixnum-> fixnum->)
(lambda (code-vector index value)
(cond ((valid-index? index (code-vector-length code-vector))
(code-vector-set! code-vector index value)
(goto return unspecific))
(else
(goto raise-exception3 0
code-vector
(enter-fixnum index)
(enter-fixnum value))))))
(define-primitive make-code-vector
(fixnum-> fixnum->)
(lambda (len init)
(let ((lose (lambda ()
(goto raise-exception2 0 (enter-fixnum len) (enter-fixnum init))))
(size (code-vector-size len)))
(if (or (< len 0)
(> size max-stob-size-in-cells))
(lose)
(maybe-ensure-space-saving-temp
size
(enter-fixnum 0)
(lambda (okay? key ignore)
(if (not okay?)
(lose)
(let ((code-vector (make-code-vector len key)))
(do ((i (- len 1) (- i 1)))
((< i 0))
(code-vector-set! code-vector i init))
(goto return code-vector)))))))))
; Strings
(define-primitive string-length
(string->)
(lambda (string)
(goto return-fixnum (vm-string-length string))))
(define-primitive string-ref
(string-> fixnum->)
(lambda (string index)
(if (valid-index? index (vm-string-length string))
(goto return-char (vm-string-ref string index))
(goto raise-exception2 0 string (enter-fixnum index)))))
(define-primitive string-set!
(string-> fixnum-> char->)
(lambda (string index char)
(cond ((valid-index? index (vm-string-length string))
(vm-string-set! string index char)
(goto return unspecific))
(else
(goto raise-exception3 0
string
(enter-fixnum index)
(enter-char char))))))
(define-primitive make-string
(fixnum-> char->)
(lambda (len init)
(let ((lose (lambda ()
(goto raise-exception2 0 (enter-fixnum len) (enter-char init))))
(size (vm-string-size len)))
(if (or (< len 0)
(> size max-stob-size-in-cells))
(lose)
(maybe-ensure-space-saving-temp
size
(enter-fixnum 0)
(lambda (okay? key ignore)
(if (not okay?)
(lose)
(let ((string (vm-make-string len key)))
(do ((i (- len 1) (- i 1)))
((< i 0))
(vm-string-set! string i init))
(goto return string)))))))))
; Constructors
(define-primitive make-stored-object
()
(lambda ()
(let* ((key (ensure-space (cells->bytes (+ 1 (this-byte)))))
(len (next-byte)) ; can't consume this byte until after ENSURE-SPACE
(new (make-d-vector (next-byte) len key)))
(cond ((>= len 1)
(d-vector-set! new (- len 1) *val*)
(do ((i (- len 2) (- i 1)))
((> 0 i)
(unassigned)) ; for the type checker!
(d-vector-set! new i (pop)))))
new))
return)
(define-primitive make-vector-object (fixnum-> any->)
(lambda (len init)
(let* ((type (next-byte))
(lose (lambda (init)
(goto raise-exception3 1 (enter-fixnum type)
(enter-fixnum len) init)))
(size (vm-vector-size len)))
(if (or (< len 0)
(> size max-stob-size-in-cells))
(lose init)
(maybe-ensure-space-saving-temp size init
(lambda (okay? key init)
(if (not okay?)
(lose init)
(let ((v (make-d-vector type len key)))
(do ((i (- len 1) (- i 1)))
((< i 0))
(d-vector-set! v i init))
(goto return v)))))))))
(define-primitive location-defined? (location->)
(lambda (loc)
(return-boolean (or (not (undefined? (contents loc)))
(= (contents loc) unassigned-marker)))))
(define-primitive set-location-defined?! (location-> boolean->)
(lambda (loc value)
(cond ((not value)
(set-contents! loc unbound-marker))
((undefined? (contents loc))
(set-contents! loc unassigned-marker)))
(goto return unspecific)))
(define-primitive immutable? (any->) immutable? return-boolean)
(define-primitive make-immutable! (any->)
(lambda (thing)
(make-immutable! thing)
(goto return thing)))
; I/O primitives
(define port-> (input-type port? no-coercion))
(define input-port-> (input-type vm-input-port? no-coercion))
(define output-port-> (input-type vm-output-port? no-coercion))
(define open-input-port->
(input-type (lambda (p)
(and (vm-input-port? p)
(open? p)))
no-coercion))
(define open-output-port->
(input-type (lambda (p)
(and (vm-output-port? p)
(open? p)))
extract-port))
(define-primitive input-port? (any->) vm-input-port? return-boolean)
(define-primitive output-port? (any->) vm-output-port? return-boolean)
(define-consing-primitive open-port (string-> fixnum->)
(lambda (ignore) port-size)
(lambda (filename mode key)
(open-port filename mode key
collect-saving-temp ; a GC may be needed to free up a port
(lambda (vm-port) ; all is okay
(goto return vm-port))
(lambda (filename) ; OS couldn't open filename
(goto return false))
(lambda (filename) ; VM is out of port descriptors
(goto raise-exception2 0 filename (enter-fixnum key))))))
(define-primitive close-port (port->) close-port return-unspecific)
(define-primitive read-char (open-input-port->)
(lambda (port)
(let ((c (peeked-char port)))
(goto return (cond ((false? c)
(ps-read-char (extract-port port)
enter-char
(lambda () eof-object)))
(else
(set-peeked-char! port false)
c))))))
(define-primitive peek-char (open-input-port->)
(lambda (port)
(let ((c (peeked-char port)))
(goto return (cond ((false? c)
(let ((c (ps-read-char (extract-port port)
enter-char
(lambda () eof-object))))
(set-peeked-char! port c)
c))
(else c))))))
(define-primitive char-ready? (open-input-port->)
(lambda (port)
(goto return (enter-boolean (or (not (false? (peeked-char port)))
(char-ready? (extract-port port)))))))
(define-primitive write-char (char-> open-output-port->)
(lambda (c port)
(write-char c port)
(goto return unspecific)))
(define-primitive write-string (string-> open-output-port->)
(lambda (s port)
(write-vm-string s port)
(goto return unspecific)))
(define-primitive force-output (open-output-port->)
(lambda (port)
(force-output port)
(goto return unspecific)))
; Misc
(define-primitive false ()
(lambda ()
(goto return false)))
(define-primitive trap (any->)
(lambda (arg)
(goto raise-exception1 0 arg)))
(define-primitive find-all-symbols (vector->)
(lambda (table)
(if (walk-over-symbols
(lambda (symbol)
(if (available? vm-pair-size)
(let ((key (preallocate-space vm-pair-size)))
(add-to-symbol-table symbol table key)
#t)
#f)))
(goto return unspecific)
(goto raise-exception 0))))
(define-primitive find-all-xs (fixnum->)
(lambda (type)
(let ((vector (find-all-xs type)))
(if (not (false? vector))
(goto return vector)
(goto raise-exception1 0 (enter-fixnum type))))))
; RESUME-PROC is called when the image is resumed.
; This does a garbage collection rooting from RESUME-PROC, writes the heap
; into a file, and then aborts the garbage collection (which didn't modify
; any VM registers or the stack).
(define-primitive write-image (string-> any-> string->)
(lambda (filename resume-proc comment-string)
(if (not (image-writing-okay?))
(goto raise-exception2 0 filename resume-proc)
(let ((port (open-output-file (extract-string filename))))
(cond ((null-port? port)
(goto raise-exception2 0 filename resume-proc))
(else
(write-vm-string comment-string port)
(begin-collection)
(let ((resume-proc (trace-value resume-proc)))
(do-gc)
(close-untraced-ports!)
(let ((size (write-image port resume-proc)))
(close-output-port port)
(abort-collection)
(goto return (enter-fixnum size))))))))))
(define-primitive collect ()
(lambda ()
(set! *val* unspecific)
(collect)
(goto return unspecific)))
(define-primitive memory-status (fixnum-> any->)
(lambda (key other)
(cond ((= key (enum memory-status-option available))
(goto return (enter-fixnum (available))))
((= key (enum memory-status-option heap-size))
(goto return
(enter-fixnum
(bytes->cells (heap-size)))))
((= key (enum memory-status-option stack-size))
(goto return (enter-fixnum (stack-size))))
((= key (enum memory-status-option set-minimum-recovered-space!))
(cond ((fixnum? other)
(let ((old *minimum-recovered-space*))
(set! *minimum-recovered-space*
(extract-fixnum other))
(goto return (enter-fixnum old))))
(else
(goto raise-exception2 0 (enter-fixnum key) other))))
((= key (enum memory-status-option gc-count))
(goto return (enter-fixnum (gc-count))))
(else
(goto raise-exception2 0 (enter-fixnum key) other)))))
(define-primitive time (fixnum-> any->)
(lambda (key other)
(cond ((= key (enum time-option ticks-per-second))
(goto return (enter-fixnum (ps-ticks-per-second))))
((= key (enum time-option run-time))
(goto return (enter-fixnum (ps-run-time))))
((= key (enum time-option real-time))
(goto return (enter-fixnum (ps-real-time))))
(else
(goto raise-exception2 0 (enter-fixnum key) other)))))
(define-primitive schedule-interrupt (fixnum->)
(lambda (time)
(clear-interrupt! (enum interrupt alarm))
(goto return (enter-fixnum (ps-schedule-interrupt time)))))
(define external-> (input-type external? no-coercion))
(define-primitive external-lookup (external->)
(lambda (external)
(let ((name (external-name external))
(value (external-value external)))
(if (and (vm-string? name)
(code-vector? value)
(lookup-external-name (address-after-header name)
(address-after-header value)))
(goto return unspecific)
(goto raise-exception1 0 external)))))
; This is only for the closed-compiled version of EXTERNAL-CALL.
;
; This is a mess because the arguments have been pushed on the stack after
; the procedure.
; The top-level driver loop removes the procedure and the arguments from
; the stack.
(define-primitive external-call ()
(lambda ()
(let ((proc (stack-ref (- *nargs* 1))))
(cond ((not (external? proc))
(goto raise-exception1 0 proc)) ; lots of junk on the stack...
(else
(set! *nargs* (- *nargs* 1)) ; don't count the procedure
(set! *val* proc)
(enum return-option external-call)))))) ; return to driver loop
(define-primitive vm-extension (fixnum-> any->)
(lambda (key value)
(let ((return-value (extended-vm key value)))
(if (undefined? return-value)
(goto raise-exception2 0 (enter-fixnum key) value)
(goto return return-value)))))
(define-primitive vm-return (fixnum-> any->)
(lambda (key value)
(set! *val* value)
(enum return-option exit))) ; the VM returns this value
(define-primitive get-dynamic-state ()
(lambda () *dynamic-state*)
return-any)
(define-primitive set-dynamic-state! (any->)
(lambda (state)
(set! *dynamic-state* state)
unspecific)
return-any)
; Unnecessary primitives
(define-primitive string=? (string-> string->) vm-string=? return-boolean)
; Special primitive called by the reader.
; Primitive for the sake of speed. Probably should be flushed.
(define-consing-primitive reverse-list->string (any-> fixnum->)
(lambda (n) (vm-string-size n))
(lambda (l n k)
(if (not (or (vm-pair? l) (vm-eq? l null)))
(goto raise-exception2 0 l (enter-fixnum n))
(let ((obj (vm-make-string n k)))
(do ((l l (vm-cdr l))
(i (- n 1) (- i 1)))
((< i 0) (goto return obj))
(vm-string-set! obj i (extract-char (vm-car l))))))))
(define-primitive string-hash (string->) vm-string-hash return-fixnum)
(define-consing-primitive intern (string-> vector->)
(lambda (ignore) (+ vm-symbol-size vm-pair-size))
intern
return)
;#|
;(define-primitive vector (fixnum->)
; (let* ((min-args (next-byte))
; (len (- *nargs* min-args))
; (key (ensure-space (vector-size len)))
; (vec (make-vector len)))
; (do ((i (- len 1) (- i 1)))
; ((= i -1)
; (set! *val* l)
; (set! *nargs* (+ min-args 1))
; (goto interpret))
; (vector-set vec i (pop)))))
;|#
; Eventually add make-table, table-ref, table-set! as primitives?
; No -- write a compiler instead.