File: arch.scm

package info (click to toggle)
scsh 0.5.1-2
  • links: PTS
  • area: non-free
  • in suites: potato, slink
  • size: 6,540 kB
  • ctags: 8,656
  • sloc: lisp: 39,346; ansic: 13,466; sh: 1,669; makefile: 624
file content (281 lines) | stat: -rw-r--r-- 8,938 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.


; This is file arch.scm.

;;;; Architecture description

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

(define bits-used-per-byte 8)

; Maximum number of arguments that can be pushed on the stack to make a call,
; also the maximum number of arguments + temporaries allowed on the stack.
(define maximum-stack-args 63)

; 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
;  index     - a byte indexing 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)))))))

(define-instruction-set
  (check-nargs=   nargs)         ; error if *nargs* not= operand
  (check-nargs>=  nargs)         ; error if *nargs* < operand
  (nargs)                        ; move *nargs* to *val*
  (make-env       nargs)         ; cons an environment
  (make-heap-env  nargs)         ; cons an environment in the heap
  (pop-env)                      ; use superior env
  (make-rest-list nargs +)       ; pop all but nargs things off the stack
                                 ; into a list
  (literal        index)         ; value to *val*
  (local          byte byte)     ; back and over
  ((local0 local1 local2)
   byte)                         ; back encoded into op-code for efficiency
  (set-local!     byte byte 1)   ; back over value
  (global         index)         ; value to *val*
  (set-global!    index 1)
  (closure        index)         ; use environment in *env*
  (push 1)                       ; push *val* onto stack
  (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 nargs)  ; save state in *cont*
  (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)

  ;; five different ways to call procedures
  (call               nargs 1 +) ; last argument is the procedure to call
  (move-args-and-call nargs 1 +) ; same, move args to just above *cont* first
  (apply              nargs 1 +) ; last argument is a list of additional 
                                 ; arguments, second to last is procedure to
                                 ; call
  (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 +)                     ; values are on stack, count is in *nargs*
  (return-values nargs +)        ; values are on stack, count is next byte
  (ignore-values +)              ; ignore (and dispose of) returned values

  ;; Five different ways to jump
  (goto-template        index)   ; jump to another template
                                 ; does not poll for interrupts
  (call-template  nargs index)   ; call a template instead of a procedure
                                 ; nargs is needed for interrupt handling
  (jump-if-false  offset 1)      ; boolean in *val*
  (jump           offset)
  (computed-goto  byte offset 1) ; jump using delta specified by *val*
                                 ; default to instruction after deltas


  ;; 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)
  (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-code-vector 2)
  (code-vector-length 1)
  (code-vector-ref 2)
  (code-vector-set! 3)

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

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

  ;; I/O
  (open-port 2)
  ((close-port input-port? output-port?) 1)
  ((read-char peek-char char-ready?) 1 0)
  (write-char 2 1)
  (write-string 2)
  (force-output 1)

  ;; Misc
  ((unassigned unspecific))
  (trap 1)                      ; raise exception specified by argument
  (false)                       ; return #f (for bootstrapping)
  (write-image 3)
  (collect)
  (memory-status 2)
  (find-all-symbols 1)          ; puts the symbols in a table
  (find-all-xs 1)               ; returns a vector containing all Xs
  (get-dynamic-state)
  (set-dynamic-state! 1)
  (set-exception-handler! 1)
  (set-interrupt-handlers! 1)
  (set-enabled-interrupts! 1)
  (return-from-interrupt)
  (schedule-interrupt 1)
  (external-lookup 1)
  (external-call 1 +)
  (time 2)
  (vm-extension 2)              ; access to extensions of the virtual machine
  (vm-return 2)                 ; return from the vm in a restartable fashion

  ;; Unnecessary primitives
  (string=? 2)
  (string-hash 1)
  (reverse-list->string 2)
  (intern 2)
  )

(define-enumeration interrupt
  (alarm       ; order matters - higher priority first
   keyboard
   memory-shortage
   chld			; From here down are the scsh/Unix interrupts.
   cont
   hup
   quit
   term
   tstp
   usr1
   usr2
   info
   io
   poll
   prof
   pwr
   urg
   vtalrm
   winch
   xcpu
   xfsz
   ))

; Options for op/time

(define-enumeration time-option
  (ticks-per-second
   run-time
   real-time
   ))

; Options for op/memory-status

(define-enumeration memory-status-option
  (available
   heap-size
   stack-size
   set-minimum-recovered-space!
   gc-count
   ))

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

   ;; B-vector types (not traced by GC)
   string        ; = least b-vector type
   code-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? make-symbol       ; symbols actually made using op/intern
      (symbol->string #f))
    (location location? make-location
      (contents set-contents!) (location-id set-location-id!))
    (closure closure? make-closure
      (closure-template #f) (closure-env #f))
    (weak-pointer weak-pointer? make-weak-pointer
      (weak-pointer-ref #f))
    (external external? make-external
      (external-name #f) (external-value #f))
    ))