File: assem.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 (317 lines) | stat: -rw-r--r-- 10,645 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
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.

; Byte-code assembler (Richard's version)

; (lap <spec> <insts>*)
; <spec> ::= <identifier> | (<identifier> <arg>*)
; <arg>  ::= <identifier>
; <inst> ::= (<op-code> . <operands>) |
;            <label> |
;            (global <identifier>) |
;            (set-global! <identifier>) |
;            (local <identifer>) |
;            (set-local! <identifier>) |
;            (literal <anything>) | (literal (quote <anything>)) |
;            (computed-goto <label>* <default-label>)  ; not yet implemented
; <operand> ::= <number> | <label> | <stob-name> |
;               (lap <spec> <insts>*) ; only where a template is expected
;              
; If any <arg>'s are specified, you have to do a MAKE-ENV to get LOCAL and
; SET-LOCAL! to work properly (the assembler assumes that you are using
; environments in the same way as the byte-code compiler).
;
; QUOTE is optional for literals, unless the value is itself quoted.
;
; The assembler uses opcode-arg-specs to check the number and type of arguments
; to the opcodes.

(define-compilator 'lap syntax-type
  (lambda (node cenv depth cont)
    (let* ((exp (node-form node))
	   (template (compile-lap (cadr exp) (cddr exp) cenv)))
      (fixup-template-refs! template)
      (deliver-value (instruction-with-literal op/closure template)
		     cont))))

(define template-marker (cons #f #f))

(define (make-template-marker name)
  (cons template-marker name))

(define (template-marker? x)
  (and (pair? x)
       (eq? (car x) template-marker)))

(define template-marker-name cdr)

(define (fixup-template-refs! template)
  (let ((templates '()))
    (let label ((template template))
      (if (symbol? (template-info template))
	  (set! templates (cons (cons (template-info template) template)
				templates)))
      (do ((i 0 (+ i 1)))
	  ((>= i (template-length template)))
	(if (template? (template-ref template i))
	    (label (template-ref template i)))))
    (let label ((template template))
      (do ((i 0 (+ i 1)))
	  ((>= i (template-length template)))
	(let ((x (template-ref template i)))
	  (cond ((template? x)
		 (label x))
		((not (template-marker? x)))
		((assq (template-marker-name x) templates)
		 => (lambda (t)
		      (template-set! template i (cdr t))))
		(else
		 (error "no template of this name available"
			(template-marker-name x)))))))))

(define (compile-lap spec insts cenv)
  (let ((id (if (pair? spec) (car spec) spec))
	(cenv (if (pair? spec) (bind-vars (cdr spec) cenv) cenv)))
    (segment->template (really-compile-lap insts cenv) id 0)))
    
; Assemble each instruction, keeping track of which ones use labels.
; STUFF is a list of lists of the form (<inst> <offset> . <preceding-insts>)
; which indicates that <inst> uses a label, the it ends at <offset>, and is
; preceded by <preceding-insts>.

(define (really-compile-lap insts cenv)
  (let loop ((insts insts) (segments '()) (stuff '()) (offset 0) (labels '()))
    (cond ((null? insts)
	   (fixup-lap-labels segments stuff labels))
	  ((pair? (car insts))
	   (call-with-values
	    (lambda () (assemble-instruction (car insts) cenv))
	    (lambda (segment label-use?)
	      (let ((offset (+ offset (segment-size segment))))
		(if label-use?
		    (loop (cdr insts)
			  '()
			  `((,(car insts) ,offset . ,segments) . ,stuff)
			  offset
			  labels)
		    (loop (cdr insts)
			  (cons segment segments)
			  stuff
			  offset
			  labels))))))
	  ((or (symbol? (car insts))
	       (integer? (car insts)))
	   (loop (cdr insts) segments stuff offset
		 (cons (cons (car insts) offset) labels)))
	  (else
	   (error "bad LAP instruction" (car insts))))))

; Reassemble the instruction at the beginning of each STUFF list to resolve
; the label reference and glue everything together using SEQUENTIALLY.  The
; label code assumes that the machine calculates the label from the end of
; the instruction.

(define (fixup-lap-labels segments stuff labels)
  (let loop ((stuff stuff) (segment (apply sequentially (reverse segments))))
    (if (null? stuff)
	segment
	(let* ((data (car stuff))
	       (inst (car data))
	       (offset (cadr data))
	       (segments (cddr data)))
	  (loop (cdr stuff)
		(sequentially (apply sequentially (reverse segments))
			      (reassemble-instruction inst offset labels)
			      segment))))))

; This returns two values, the assembled instruction and a flag indicating
; whether or not the instruction used a label.

(define (assemble-instruction inst cenv)
  (really-assemble-instruction inst cenv (lambda (label) (values 0 0))))

; Same as the above, except that labels are resolved and no flag is returned.

(define (reassemble-instruction inst offset labels)
  (call-with-values
   (lambda ()
     (really-assemble-instruction inst #f (resolve-label offset labels)))
   (lambda (inst ignore)
     inst)))

(define (resolve-label offset labels)
  (lambda (label)
    (cond ((assoc label labels)
	   => (lambda (p)
		(let ((delta (- (cdr p) offset)))
		  (values (quotient delta byte-limit)
			  (remainder delta byte-limit)))))
	  (else
	   (error "LAP label is not defined" label)))))

(define (really-assemble-instruction inst cenv labels)
  (let ((opname (car inst))
	(args (cdr inst)))
    (cond ((assemble-special-op opname args cenv)
	   => (lambda (inst)
		(values inst #f)))
	  ((name->enumerand opname op)
	   => (lambda (opcode)
		(assemble-general-instruction opcode inst cenv labels)))
	  (else
	   (error "unknown LAP instruction" inst)))))

; The optional ' is optionally stripped off the argument to LITERAL.

(define (assemble-special-op opname args cenv)
  (case opname
    ((literal)
     (let* ((arg (car args))
	    (arg (if (and (pair? arg)
			  (eq? (car arg) 'quote))
		     (cadr arg)
		     arg)))
       (instruction-with-literal op/literal arg)))
    ((global)
     (lap-global #f (car args) cenv))
    ((set-global!)
     (lap-global #t (car args) cenv))
    ((local)
     (if (null? (cdr args))
	 (lap-local (car args) cenv)
	 #f))
    ((set-local!)
     (if (null? (cdr args))
	 (lap-set-local! (car args) cenv)
	 #f))
    (else
     #f)))

(define (lap-global assign? name cenv)
  (let ((binding (lookup cenv name)))
    (if (and (binding? binding) (not (location? (binding-place binding))))
	(error "LAP variable is not global" name)
	(instruction-with-location
	     (if assign? op/set-global! op/global)
	     (get-location binding
			   cenv
			   name
			   (if assign? usual-variable-type value-type))))))

(define (lap-local name cenv)
  (let ((binding (lookup cenv name)))
    (if (and (binding? binding)
	     (pair? (binding-place binding)))
	(let* ((level+over (binding-place binding))
	       (back (- (environment-level cenv)
			(car level+over)))
	       (over (cdr level+over)))
	  (case back
	    ((0) (instruction op/local0 over))
	    ((1) (instruction op/local1 over))
	    ((2) (instruction op/local2 over))
	    (else (instruction op/local back over))))
	(error "LAP local variable is not locally bound" name))))
	  
(define (lap-set-local! name cenv)
  (let ((binding (lookup cenv name)))
    (if (and (binding? binding)
	     (pair? (binding-place binding)))
	(let* ((level+over (binding-place binding))
	       (back (- (environment-level cenv)
			(car level+over)))
	       (over (cdr level+over)))
	  (instruction op/set-local! back over))
	(error "LAP local variable is not locally bound" name))))

; This returns two values, the assembled instruction and a flag indicating
; whether or not the instruction used a label.

(define (assemble-general-instruction opcode inst cenv labels)
  (let ((specs (vector-ref opcode-arg-specs opcode))
	(args (cdr inst))
	(finish (lambda (ops label-use?)
		  (values (apply instruction opcode (reverse ops))
			  label-use?))))
    (let loop ((specs specs) (args args) (ops '()) (label-use? #f))
      (if (null? specs)
	  (finish ops label-use?)
	  (case (car specs)
	    ((index) ; segment.scm allows no other operands if an index is used.
                     ; All non-template indexed operands should have been taken
                     ; care of above (probably should fix arch.scm).
	     (let ((template (if (null? (cdr args))
				 (make-template-marker (car args))
				 (compile-lap (car args) (cdr args) cenv))))
	       (values (instruction-with-final-literal opcode
						       (reverse ops)
						       template)
		       label-use?)))
	    ((offset)
	     (let ((label (check-lap-arg args 'label inst)))
	       (call-with-values
		(lambda () (labels label))
		(lambda (high low)
		  (loop (cdr specs) (cdr args) `(,low ,high . ,ops) #t)))))
	    ((stob)
	     (let ((byte (check-lap-arg args 'stob inst)))
	       (loop (cdr specs) (cdr args) (cons byte ops) label-use?)))
	    ((nargs byte)
	     (let ((byte (check-lap-arg args 'byte inst)))
	       (loop (cdr specs) (cdr args) (cons byte ops) label-use?)))
	    (else
	     (if (or (eq? (car specs) '+)
		     (integer? (car specs)))
		 (finish ops label-use?)
		 (error "unknown opcode argument specification" (car specs)))))))))

; Compiler doesn't provide this so we hack it up.

(define (instruction-with-final-literal opcode operands literal)
  (cond ((null? operands)
	 (instruction-with-literal opcode literal))
	(else
	 (sequentially (apply instruction
			      opcode
			      (reverse (cdr (reverse operands))))
		       (instruction-with-literal (car (reverse operands))
						 literal)))))

; Check that the car of ARGS is an argument of the appropriate type and
; return it.

(define (check-lap-arg args type inst)
  (if (null? args)
      (error "not enough arguments in LAP instruction" inst))
  (let ((arg (car args)))
    (case type
      ((byte)
       (if (integer? arg)
	   arg
	   (error "numeric operand expected in LAP instruction" inst)))
      ((stob)
       (cond ((name->enumerand arg stob)
	      => (lambda (x) x))
	     (else
	      (error "unknown STOB argument in LAP instruction" inst))))
      ((label)
       (cond ((symbol? arg)
	      arg)
	     ((and (pair? arg)
		   (eq? (car arg) '=>))
	      (cadr arg))
	     (else
	      (error "bad label in LAP instruction" inst))))
      (else
       (error "LAP internal error, unknown LAP argument specifier" type)))))
	    
(define byte-limit (expt 2 bits-used-per-byte))

(define op/closure (enum op closure))
(define op/global  (enum op global))
(define op/literal (enum op literal))
(define op/local   (enum op local))
(define op/local0  (enum op local0))
(define op/local1  (enum op local1))
(define op/local2  (enum op local2))
(define op/set-global! (enum op set-global!))
(define op/set-local!  (enum op set-local!))