scsh-0.6/scheme/vm/arch.scm

; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.

; This is file arch.scm.

;;;; Architecture description

(define architecture-version "Vanilla 20")

; Things that the VM and the runtime system both need to know.

(define bits-used-per-byte 8)

(define byte-limit (expt 2 bits-used-per-byte))

; Bytecodes: for compiler and interpreter

; Instruction specification is 
; (op . args)
; OP may be a name or a list of names
; ARGS are
;  nargs     - a byte
;  byte      - a byte
;  junk	     - a byte that is ignored (e.g. when a peephole optimization merges
;              two instructions into a single, shorter one)
;  two-bytes - two bytes
;  index       - a two byte index into the current template
;  small-index - a one byte index into the current template
;  offset    - two bytes giving an offset into the current instruction stream
;  stob      - a byte specifying a type for a stored object
;  0 1 2 ... - the number of non-instruction-stream arguments (some
;              instructions take a variable number of arguments; the first
;              number is the argument count implemented by the VM)
;  +         - any number of additional arguments are allowed

(define-syntax define-instruction-set
  (lambda (form rename compare)
    (let ((data (do ((data (reverse (cdr form)) (cdr data))
		     (new '() (let ((next (car data)))
				(if (pair? (car next))
				    (append (map (lambda (op)
						   (cons op (cdr next)))
						 (car next))
					    new)
				    (cons next new)))))
		    ((null? data) new))))
      `(begin (define-enumeration op
		,(map car data))
	      (define opcode-arg-specs
		'#(,@(map cdr data)))))))

; Instructions marked *EXP* are experimental and are not normally used by
; byte-code compiler.

(define-instruction-set
  (protocol       protocol)      ; first opcode in a procedure, never actually
				 ; executed

  (make-env       two-bytes)     ; cons an environment

  (literal        index)         ; value to *val*, two-byte index
  (small-literal  small-index)   ; value to *val*, one-byte index
  (local          byte byte)     ; back and over
  ((local0 local1 local2)
   byte)		         ; back encoded into op-code for efficiency
  (big-local      two-bytes two-bytes)   ; same, but counts are two bytes
  (set-local!     two-bytes two-bytes 1) ; back over value, counts are two bytes
  (global         index)         ; value to *val*
  (set-global!    index 1)
  (closure        index byte)    ; byte = 0 -> use environment in *env*
                                 ; byte = 1 -> use environment in *val*
  (make-flat-env  env-data)      ; make new environment from env-data
  (push 1)		         ; push *val* onto stack
  ((local0-push push-local0)	 ; common combination
		  byte junk 1)
  (pop)			         ; pop top of stack into *val*
  (stack-ref      byte)	         ; index'th element of stack into *val*
  (stack-set!     byte 1)        ; *val* to index'th element of stack

  (make-cont      offset byte)      ; save state in *cont*
  (make-big-cont  offset two-bytes) ; save state in *cont*, two-byte size
  (current-cont)	         ; copy *cont* to *val*, use WITH-CONTINUATION
			         ; to use copied continuation
  (get-cont-from-heap)	         ; copy next continuation from heap (this
			         ; op-code is used internally by the VM)

  ;; different ways to call procedures
  (call     nargs     1 +)       ; last argument is the procedure to call
  (big-call two-bytes 1 +)       ; ditto, nargs count is two bytes
  (move-args-and-call nargs 1 +) ; same, move args to just above *cont* first
  				 ; (*EXP*, and no two-byte version)
  (apply    two-bytes 2 +)       ; last argument is procedure to call, second to
				 ; last is a list of additional arguments, next
                                 ; two bytes are the number of stack arguments
  (closed-apply 2 +)		 ; arguments are as for Scheme's APPLY, with
				 ; the number of non-list arguments pushed on
  				 ; the top of the stack
  (with-continuation 2)		 ; first arg is cont, second is procedure
  (call-with-values +)		 ; values are on stack, consumer is in the
				 ; continuation pointed to by *cont*

  ;; Three different ways to return from calls and one way to ignore any
  ;; returned values
  (return 1)			 ; return to continuation in *cont*
  (values two-bytes +)		 ; values are on stack, count is next two bytes
  (closed-values +)		 ; values are on stack, count is pushed on stack
  (ignore-values +)		 ; ignore (and dispose of) returned values

  ;; Different ways to jump
  (goto-template        index)	 ; jump to another template (*EXP*)
				 ; does not poll for interrupts
  (call-template  index nargs)	 ; call a template instead of a procedure
				 ; nargs is needed for interrupt handling
  				 ; Current VM only handles the zero-arg case.
  (jump-if-false  offset 1)	 ; boolean in *val*
  (jump           offset)
  (computed-goto  byte offset 1) ; jump using delta specified by *val*
				 ; defaults to instruction after deltas (*EXP*)

  ;; For the closed-compiled definitions of n-ary arithmetic functions.
  ;; The opcode sequences used are:
  ;;       binary-reduce1 binary-op binary-reduce2 return
  ;; and
  ;;       binary-reduce1 binary-op binary-comparison-reduce2 return
  ((binary-reduce1 binary-reduce2 binary-comparison-reduce2))

  ;; Scalar primitives
  (eq? 2)

  ((number? integer? rational? real? complex? exact?) 1)
  ((exact->inexact inexact->exact) 1)

  ((+ *) 2 0 1 +)
  ((- /) 2 1)
  ((= < > <= >=) 2 +)
  ((quotient remainder) 2)
  ((floor numerator denominator
     real-part imag-part
     exp log sin cos tan asin acos sqrt
     angle magnitude)
   1)
  (atan 2)
  ((make-polar make-rectangular) 2)
  (bitwise-not 1)
  ((bitwise-and bitwise-ior bitwise-xor) 2)
  (arithmetic-shift 2)
  (char? 1)
  ((char=? char<?) 2)
  ((char->ascii ascii->char) 1)
  (eof-object? 1)

  ;; Data manipulation
  (stored-object-has-type? stob 1)
  (stored-object-length stob 1)

  (make-stored-object byte stob)
  (closed-make-stored-object stob) ; size pushed on stack
  (stored-object-ref  stob byte 1) ; byte is the offset
  (stored-object-set! stob byte 2)

  (make-vector-object stob 2)	      ; size + init
  (stored-object-indexed-ref  stob 2) ; vector + offset
  (stored-object-indexed-set! stob 3) ; vector + offset + value

  (make-byte-vector 2)
  (byte-vector-length 1)
  (byte-vector-ref 2)
  (byte-vector-set! 3)

  (make-string 2)
  (string-length 1)
  (string-ref 2)
  (string-set! 3)

  (intern 1)
                     
  (location-defined? 1)
  (set-location-defined?! 2)
  ((immutable? make-immutable!) 1)

  ;; channels (unbuffered, non-blocking I/O)
  (open-channel 2)
  (close-channel 1)
  (channel-maybe-read 5)
  (channel-maybe-write 4)
  (channel-ready? 1)
  (channel-abort 1)             ; stop channel operation
  (open-channels-list)		; return a list of the open channels
  
  ;; Misc
  ((unassigned unspecific))
  (trap 1)			; raise exception
  (false)			; return #f (for bootstrapping)
  (eof-object)                  ; hard to get otherwise
  (write-image 3)
  (collect)
  (string-hash 1)		; used by the static linker for the initial table
  (add-finalizer! 2)
  (memory-status 2)
  (find-all 1)	                ; makes a vector of all objects of a given type
  (find-all-records 1)          ; makes a vector of all records of a given type
  (current-thread)
  (set-current-thread! 1)
  (session-data)                ; session specific data
  (set-session-data! 1)
  (set-exception-handlers! 1)
  (return-from-exception 1)
  (set-interrupt-handlers! 1)
  (set-enabled-interrupts! 1)
  (return-from-interrupt)
  (schedule-interrupt 1)
  (wait 2)                      ; do nothing until something happens
  (call-external-value 1 +)
  (lookup-shared-binding 2)
  (define-shared-binding 3)
  (undefine-shared-binding 2)
  (time 2)
  (vm-extension 2)		; access to extensions of the virtual machine
  (return-from-callback 2)	; return from an callback

  ;; Unnecessary primitives
  (string=? 2)
  (reverse-list->string 2)
  (assq 2)
  (checked-record-ref 3)
  (checked-record-set! 4)
  (copy-bytes! 5)

  ;; ports (buffered I/O) - these are all unnecessary
  ;; byte = 0 -> port is supplied
  ;;      = 1 -> get port from dynamic environment
  ((read-char peek-char) byte 1 0)
  (write-char byte 2 1)

  ;; For writing informative messages when debugging
  (message 1)
  )

(define-enumeration interrupt
  (alarm           ; order matters - higher priority first
   keyboard
   post-gc         ; handler is passed a list of finalizers
   i/o-completion  ; handler is passed channel and status
   os-signal       
   ))

; Possible problems

(define-enumeration exception
  (unassigned-local
   undefined-global
   unbound-global
   bad-procedure
   wrong-number-of-arguments
   wrong-type-argument
   arithmetic-overflow
   index-out-of-range
   heap-overflow
   out-of-memory
   cannot-open-channel
   channel-os-index-already-in-use
   closed-channel
   pending-channel-i/o
   buffer-full/empty
   unimplemented-instruction
   trap
   proceeding-after-exception
   bad-option
   unbound-external-name
   too-many-arguments-to-external-procedure
   too-many-arguments-in-callback
   callback-return-uncovered
   extension-exception
   extension-return-error
   os-error
   unresumable-records-in-image
   gc-protection-mismatch
   ))

; Used by (READ-CHAR) and (WRITE-CHAR) to get the appropriate ports from
; the fluid environment.

(define-enumeration current-port-marker
  (current-input-port
   current-output-port))

;----------------
; Encoding for template protocols:
; 0 ... MAX-STACK-ARGS = that number of arguments, no rest list
; TWO-BYTE-NARGS = (2*MAX-STACK-ARGS)+1 = next two bytes are the fixed argument
;  count
; TWO-BYTE-NARGS+LIST = TWO-BYTE-NARGS + 1 = next two bytes are the fixed
;  argument count, plus a rest list

(define maximum-stack-args 63)

(define *last-protocol* maximum-stack-args)

(define (next-protocol)
  (set! *last-protocol* (+ *last-protocol* 1))
  *last-protocol*)

(define two-byte-nargs-protocol      (next-protocol))

; Used for all n-ary procedures.

(define two-byte-nargs+list-protocol (next-protocol))

; Real protocol is at the end of the code vector, along with the required
; stack size:
;   ... real-protocol stack-size0 stack-size1
; This stuff has to be at the end of the code vector because the necessary stack
; size is not determined until after the code vector has been assembled.

(define big-stack-protocol (next-protocol))

; The rest are used only for the definitions of various Scheme primitives.

; For VECTOR, RECORD, VALUES, EXTERNAL-CALL, APPLY
; Next byte is the minimum number of arguments (1 for EXT-CALL, 2 for APPLY,
; 0 for the rest).
; Stack = arg0 arg1 ... argN rest-list N+1 total-arg-count
; The first two arguments are always on the stack.

(define args+nargs-protocol (next-protocol))

; Followed by four bytes: the offsets of code for the 0, 1, 2, and 3+ arg cases.
; A zero indicatest that the primitive doesn't accept that many arguments.
; If there are fewer than three arguments they are all on the stack.  In the
; 3+ case this is the same as args+nargs above.

(define nary-dispatch-protocol (next-protocol))

; The maximum number of arguments that can be passed to EXTERNAL-CALL.
; This is determined by the C procedure `external_call()'.

(define maximum-external-call-args 12)

;----------------
; The number of stack slots available to each procedure by default.
; Procedures that need more than this must use one of the two-byte-nargs
; protocols.  All of these are given in terms of descriptors.

(define default-stack-space 64)

(define environment-stack-size 2)   ; header + superior environment
(define continuation-stack-size 5)  ; header + continuation + template +
                                    ;  pc + env

(define available-stack-space 8000) ; how much stack space is available for
                                    ; any one procedure

;----------------

; Options for op/time

(define-enumeration time-option
  (run-time
   real-time
   cheap-time     ; cheap (no system call) access to the polling clock
   ;current-time
   ))

; Options for op/memory-status

(define-enumeration memory-status-option
  (available
   heap-size
   stack-size
   gc-count
   expand-heap!
   pointer-hash
   ))

; The two types of special channels cannot be used for normal I/O.

(define-enumeration channel-status-option
  (closed
   input
   output
   special-input   ; socket accept, ???
   special-output  ; ???
   ))

; Indicies into a port's status word

(define-enumeration port-status-options
  (input
   output
   open-for-input
   open-for-output
   ))

(define-enumeration stob
  (;; D-vector types (traced by GC)
   pair
   symbol
   vector
   closure
   location
   cell
   channel
   port
   ratnum
   record
   continuation
   extended-number
   template
   weak-pointer
   shared-binding
   unused-d-header1
   unused-d-header2

   ;; B-vector types (not traced by GC)
   string        ; = least b-vector type
   byte-vector
   double        ; double precision floating point
   bignum
   ))

; This is here to try to ensure that it is changed when STOB changes.
(define least-b-vector-type (enum stob string))

; (stob predicate constructor . (accessor modifier)*)
; If nothing else, the run-time system and the VM need to agree on
; which slot of a pair is the car and which is the cdr.

(define stob-data
  '((pair pair? cons
      (car set-car!) (cdr set-cdr!))
    (symbol symbol? #f       ; RTS calls op/string->symbol
      (symbol->string))
    (location location? make-location
      (location-id set-location-id!)
      (contents set-contents!))
    (cell cell? make-cell
      (cell-ref cell-set!))
    (closure closure? make-closure
      (closure-template) (closure-env))
    (weak-pointer weak-pointer? make-weak-pointer
      (weak-pointer-ref))
    (shared-binding shared-binding? make-shared-binding
      (shared-binding-name)
      (shared-binding-is-import?)
      (shared-binding-ref shared-binding-set!))
    (port port? make-port
      (port-handler set-port-handler!)
      (port-status  set-port-status!)
      (port-lock    set-port-lock!)
      (port-locked? set-port-locked?!)
      (port-data    set-port-data!)
      (port-buffer  set-port-buffer!)
      (port-index   set-port-index!)
      (port-limit   set-port-limit!)
      (port-pending-eof? set-port-pending-eof?!))
    (channel channel? #f
      (channel-status)
      (channel-id)
      (channel-os-index))
    ))