| blob | 27517744d92f93cf55492143af4d58898d233c40 |
1 ;;;; File: "encoding.scm", Time-stamp: <2006-05-08 16:04:37 feeley>
3 ;;;; Copyright (C) 2004-2009 by Marc Feeley and Vincent St-Amour
4 ;;;; All Rights Reserved.
6 (define min-fixnum-encoding 3)
7 (define min-fixnum -1)
8 (define max-fixnum 255)
9 (define min-rom-encoding (+ min-fixnum-encoding (- max-fixnum min-fixnum) 1))
10 (define min-ram-encoding 512)
11 (define max-ram-encoding 1279)
12 (define min-vec-encoding 1280)
13 (define max-vec-encoding 2047)
15 (define code-start #x8000)
17 (define (predef-constants) (list))
19 (define (predef-globals) (list))
21 (define (encode-direct obj)
22 (cond ((eq? obj #f)
23 0)
24 ((eq? obj #t)
25 1)
26 ((eq? obj '())
27 2)
28 ((and (integer? obj)
29 (exact? obj)
30 (>= obj min-fixnum)
31 (<= obj max-fixnum))
32 (+ obj (- min-fixnum-encoding min-fixnum)))
33 (else
34 #f)))
36 (define (translate-constant obj)
37 (if (char? obj)
38 (char->integer obj)
39 obj))
41 (define (encode-constant obj constants)
42 (let ((o (translate-constant obj)))
43 (let ((e (encode-direct o)))
44 (if e
45 e
46 (let ((x (assoc o constants)))
47 (if x
48 (vector-ref (cdr x) 0)
49 (compiler-error "unknown object" obj)))))))
51 ;; TODO actually, seem to be in a pair, scheme object in car, vector in cdr
52 ;; constant objects are represented by vectors
53 ;; 0 : encoding (ROM address) TODO really the ROM address ?
54 ;; 1 : TODO asm label constant ?
55 ;; 2 : number of occurences of this constant in the code
56 ;; 3 : pointer to content, used at encoding time
57 (define (add-constant obj constants from-code? cont)
58 (let ((o (translate-constant obj)))
59 (let ((e (encode-direct o)))
60 (if e
61 (cont constants)
62 (let ((x (assoc o constants)))
63 (if x
64 (begin
65 (if from-code?
66 (vector-set! (cdr x) 2 (+ (vector-ref (cdr x) 2) 1)))
67 (cont constants))
68 (let* ((descr
69 (vector #f
70 (asm-make-label 'constant)
71 (if from-code? 1 0)
72 #f))
73 (new-constants
74 (cons (cons o descr)
75 constants)))
76 (cond ((pair? o)
77 (add-constants (list (car o) (cdr o))
78 new-constants
79 cont))
80 ((symbol? o)
81 (cont new-constants))
82 ((string? o)
83 (let ((chars (map char->integer (string->list o))))
84 (vector-set! descr 3 chars)
85 (add-constant chars
86 new-constants
87 #f
88 cont)))
89 ((vector? o) ; ordinary vectors are stored as lists
90 (let ((elems (vector->list o)))
91 (vector-set! descr 3 elems)
92 (add-constant elems
93 new-constants
94 #f
95 cont)))
96 ((u8vector? o)
97 (let ((elems (u8vector->list o)))
98 (vector-set! descr 3 elems)
99 (add-constant elems
100 new-constants
101 #f
102 cont)))
103 ((and (number? o) (exact? o))
104 ; (pp (list START-ENCODING: o))
105 (let ((hi (arithmetic-shift o -16)))
106 (vector-set! descr 3 hi)
107 ;; recursion will stop once we reach 0 or -1 as the
108 ;; high part, which will be matched by encode-direct
109 (add-constant hi
110 new-constants
111 #f
112 cont)))
113 (else
114 (cont new-constants))))))))))
116 (define (add-constants objs constants cont)
117 (if (null? objs)
118 (cont constants)
119 (add-constant (car objs)
120 constants
121 #f
122 (lambda (new-constants)
123 (add-constants (cdr objs)
124 new-constants
125 cont)))))
127 (define (add-global var globals cont)
128 (let ((x (assq var globals)))
129 (if x
130 (begin
131 ;; increment reference counter
132 (vector-set! (cdr x) 1 (+ (vector-ref (cdr x) 1) 1))
133 (cont globals))
134 (let ((new-globals
135 (cons (cons var (vector (length globals) 1))
136 globals)))
137 (cont new-globals)))))
139 (define (sort-constants constants)
140 (let ((csts
141 (sort-list constants
142 (lambda (x y)
143 (> (vector-ref (cdr x) 2)
144 (vector-ref (cdr y) 2))))))
145 (let loop ((i min-rom-encoding)
146 (lst csts))
147 (if (null? lst)
148 ;; constants can use all the rom addresses up to 256 constants since
149 ;; their number is encoded in a byte at the beginning of the bytecode
150 (if (or (> i min-ram-encoding) (> (- i min-rom-encoding) 256))
151 (compiler-error "too many constants")
152 csts)
153 (begin
154 (vector-set! (cdr (car lst)) 0 i)
155 (loop (+ i 1)
156 (cdr lst)))))))
158 (define (sort-globals globals) ;; TODO a lot in common with sort-constants, ABSTRACT
159 (let ((glbs
160 (sort-list globals
161 (lambda (x y)
162 (> (vector-ref (cdr x) 1)
163 (vector-ref (cdr y) 1))))))
164 (let loop ((i 0)
165 (lst glbs))
166 (if (null? lst)
167 (if (> i 256) ;; the number of globals is encoded on a byte
168 (compiler-error "too many global variables")
169 glbs)
170 (begin
171 (vector-set! (cdr (car lst)) 0 i)
172 (loop (+ i 1)
173 (cdr lst)))))))
175 (define assemble
176 (lambda (code hex-filename)
177 (let loop1 ((lst code)
178 (constants (predef-constants))
179 (globals (predef-globals))
180 (labels (list)))
181 (if (pair? lst)
183 (let ((instr (car lst)))
184 (cond ((number? instr)
185 (loop1 (cdr lst)
186 constants
187 globals
188 (cons (cons instr (asm-make-label 'label))
189 labels)))
190 ((eq? (car instr) 'push-constant)
191 (add-constant (cadr instr)
192 constants
193 #t
194 (lambda (new-constants)
195 (loop1 (cdr lst)
196 new-constants
197 globals
198 labels))))
199 ((memq (car instr) '(push-global set-global))
200 (add-global (cadr instr)
201 globals
202 (lambda (new-globals)
203 (loop1 (cdr lst)
204 constants
205 new-globals
206 labels))))
207 (else
208 (loop1 (cdr lst)
209 constants
210 globals
211 labels))))
213 (let ((constants (sort-constants constants))
214 (globals (sort-globals globals)))
216 (define (label-instr label opcode)
217 (asm-at-assembly
218 ;; if the distance from pc to the label fits in a single byte,
219 ;; a short instruction is used, containing a relative address
220 ;; if not, the full 16-bit label is used
221 ;;; (lambda (self)
222 ;;; (let ((dist (- (asm-label-pos label) self)))
223 ;;; (and (< dist 256) ;; TODO have this between -128 and 127 ? would be more flexible, I guess
224 ;;; (> dist 0)
225 ;;; 2)))
226 ;;; (lambda (self)
227 ;;; (asm-8 (+ opcode 5))
228 ;;; (asm-8 (- (asm-label-pos label) self)))
229 ;; TODO doesn't work at the moment
231 (lambda (self)
232 3)
233 (lambda (self)
234 (let ((pos (- (asm-label-pos label) code-start)))
235 (asm-8 opcode)
236 (asm-8 (quotient pos 256))
237 (asm-8 (modulo pos 256))))))
239 (define (push-constant n)
240 (if (<= n 31)
241 (asm-8 (+ #x00 n))
242 (begin
243 (asm-8 (+ #x90 (quotient n 256)))
244 (asm-8 (modulo n 256)))))
246 (define (push-stack n)
247 (if (> n 31)
248 (compiler-error "stack is too deep")
249 (asm-8 (+ #x20 n))))
251 (define (push-global n)
252 (if (<= n 15)
253 (asm-8 (+ #x40 n))
254 (begin (asm-8 #x8e)
255 (asm-8 n))))
257 (define (set-global n)
258 (if (<= n 15)
259 (asm-8 (+ #x50 n))
260 (begin (asm-8 #x8f)
261 (asm-8 n))))
263 (define (call n)
264 (if (> n 15)
265 (compiler-error "call has too many arguments")
266 (asm-8 (+ #x60 n))))
268 (define (jump n)
269 (if (> n 15)
270 (compiler-error "call has too many arguments")
271 (asm-8 (+ #x70 n))))
273 (define (call-toplevel label)
274 (label-instr label #x80))
276 (define (jump-toplevel label)
277 (label-instr label #x81))
279 (define (goto label)
280 (label-instr label #x82))
282 (define (goto-if-false label)
283 (label-instr label #x83))
285 (define (closure label)
286 (label-instr label #x84))
288 (define (prim n)
289 (asm-8 (+ #xc0 n)))
291 (define (prim.number?) (prim 0))
292 (define (prim.+) (prim 1))
293 (define (prim.-) (prim 2))
294 (define (prim.*) (prim 3))
295 (define (prim.quotient) (prim 4))
296 (define (prim.remainder) (prim 5))
297 (define (prim.neg) (prim 6))
298 (define (prim.=) (prim 7))
299 (define (prim.<) (prim 8))
300 (define (prim.<=) (prim 9))
301 (define (prim.>) (prim 10))
302 (define (prim.>=) (prim 11))
303 (define (prim.pair?) (prim 12))
304 (define (prim.cons) (prim 13))
305 (define (prim.car) (prim 14))
306 (define (prim.cdr) (prim 15))
307 (define (prim.set-car!) (prim 16))
308 (define (prim.set-cdr!) (prim 17))
309 (define (prim.null?) (prim 18))
310 (define (prim.eq?) (prim 19))
311 (define (prim.not) (prim 20))
312 (define (prim.get-cont) (prim 21))
313 (define (prim.graft-to-cont) (prim 22))
314 (define (prim.return-to-cont) (prim 23))
315 (define (prim.halt) (prim 24))
316 (define (prim.symbol?) (prim 25))
317 (define (prim.string?) (prim 26))
318 (define (prim.string->list) (prim 27))
319 (define (prim.list->string) (prim 28))
320 (define (prim.make-u8vector) (prim 29))
321 (define (prim.u8vector-ref) (prim 30))
322 (define (prim.u8vector-set!) (prim 31))
323 (define (prim.print) (prim 32))
324 (define (prim.clock) (prim 33))
325 (define (prim.motor) (prim 34))
326 (define (prim.led) (prim 35))
327 (define (prim.led2-color) (prim 36))
328 (define (prim.getchar-wait) (prim 37))
329 (define (prim.putchar) (prim 38))
330 (define (prim.beep) (prim 39))
331 (define (prim.adc) (prim 40))
332 (define (prim.u8vector?) (prim 41))
333 (define (prim.sernum) (prim 42))
334 (define (prim.u8vector-length) (prim 43))
335 (define (prim.u8vector-copy!) (prim 44))
336 (define (prim.shift) (prim 45))
337 (define (prim.pop) (prim 46))
338 (define (prim.return) (prim 47))
339 (define (prim.boolean?) (prim 48))
340 (define (prim.network-init) (prim 49))
341 (define (prim.network-cleanup) (prim 50))
342 (define (prim.receive-packet-to-u8vector) (prim 51))
343 (define (prim.send-packet-from-u8vector) (prim 52))
344 (define (prim.ior) (prim 53))
345 (define (prim.xor) (prim 54))
347 (define big-endian? #f)
349 (asm-begin! code-start #f)
351 (asm-8 #xfb)
352 (asm-8 #xd7)
353 (asm-8 (length constants))
354 (asm-8 (length globals))
356 '(pp (list constants: constants globals: globals))
358 (for-each
359 (lambda (x)
360 (let* ((descr (cdr x))
361 (label (vector-ref descr 1))
362 (obj (car x)))
363 (asm-label label)
364 ;; see the vm source for a description of encodings
365 ;; TODO have comments here to explain encoding, at least magic number that give the type
366 (cond ((and (integer? obj) (exact? obj))
367 (let ((hi (encode-constant (vector-ref descr 3)
368 constants)))
369 ; (pp (list ENCODE: (vector-ref descr 3) to: hi lo: obj))
370 (asm-8 (+ 0 (arithmetic-shift hi -8))) ;; TODO -5 has low 16 at 00fb, should be fffb, 8 bits ar lost
371 (asm-8 (bitwise-and hi #xff)) ; pointer to hi
372 (asm-8 (arithmetic-shift obj -8)) ; bits 8-15
373 (asm-8 (bitwise-and obj #xff)))) ; bits 0-7
374 ((pair? obj)
375 (let ((obj-car (encode-constant (car obj) constants))
376 (obj-cdr (encode-constant (cdr obj) constants)))
377 (asm-8 (+ #x80 (arithmetic-shift obj-car -8)))
378 (asm-8 (bitwise-and obj-car #xff))
379 (asm-8 (+ 0 (arithmetic-shift obj-cdr -8)))
380 (asm-8 (bitwise-and obj-cdr #xff))))
381 ((symbol? obj)
382 (asm-8 #x80)
383 (asm-8 0)
384 (asm-8 #x20)
385 (asm-8 0))
386 ((string? obj)
387 (let ((obj-enc (encode-constant (vector-ref descr 3)
388 constants)))
389 (asm-8 (+ #x80 (arithmetic-shift obj-enc -8)))
390 (asm-8 (bitwise-and obj-enc #xff))
391 (asm-8 #x40)
392 (asm-8 0)))
393 ((vector? obj) ; ordinary vectors are stored as lists
394 (let* ((elems (vector-ref descr 3))
395 (obj-car (encode-constant (car elems)
396 constants))
397 (obj-cdr (encode-constant (cdr elems)
398 constants)))
399 (asm-8 (+ #x80 (arithmetic-shift obj-car -8)))
400 (asm-8 (bitwise-and obj-car #xff))
401 (asm-8 (+ 0 (arithmetic-shift obj-cdr -8)))
402 (asm-8 (bitwise-and obj-cdr #xff))))
403 ((u8vector? obj)
404 (let ((obj-enc (encode-constant (vector-ref descr 3)
405 constants))
406 (l (length (vector-ref descr 3))))
407 ;; length is stored raw, not encoded as an object
408 ;; however, the bytes of content are encoded as
409 ;; fixnums
410 (asm-8 (+ #x80 (arithmetic-shift l -8)))
411 (asm-8 (bitwise-and l #xff))
412 (asm-8 (+ #x60 (arithmetic-shift obj-enc -8)))
413 (asm-8 (bitwise-and obj-enc #xff))))
414 (else
415 (compiler-error "unknown object type" obj)))))
416 constants)
418 (let loop2 ((lst code))
419 (if (pair? lst)
420 (let ((instr (car lst)))
422 (cond ((number? instr)
423 (let ((label (cdr (assq instr labels))))
424 (asm-label label)))
426 ((eq? (car instr) 'entry)
427 (let ((np (cadr instr))
428 (rest? (caddr instr)))
429 (asm-8 (if rest? (- np) np))))
431 ((eq? (car instr) 'push-constant)
432 (let ((n (encode-constant (cadr instr) constants)))
433 (push-constant n)))
435 ((eq? (car instr) 'push-stack)
436 (push-stack (cadr instr)))
438 ((eq? (car instr) 'push-global)
439 (push-global (vector-ref
440 (cdr (assq (cadr instr) globals))
441 0)))
443 ((eq? (car instr) 'set-global)
444 (set-global (vector-ref
445 (cdr (assq (cadr instr) globals))
446 0)))
448 ((eq? (car instr) 'call)
449 (call (cadr instr)))
451 ((eq? (car instr) 'jump)
452 (jump (cadr instr)))
454 ((eq? (car instr) 'call-toplevel)
455 (let ((label (cdr (assq (cadr instr) labels))))
456 (call-toplevel label)))
458 ((eq? (car instr) 'jump-toplevel)
459 (let ((label (cdr (assq (cadr instr) labels))))
460 (jump-toplevel label)))
462 ((eq? (car instr) 'goto)
463 (let ((label (cdr (assq (cadr instr) labels))))
464 (goto label)))
466 ((eq? (car instr) 'goto-if-false)
467 (let ((label (cdr (assq (cadr instr) labels))))
468 (goto-if-false label)))
470 ((eq? (car instr) 'closure)
471 (let ((label (cdr (assq (cadr instr) labels))))
472 (closure label)))
474 ((eq? (car instr) 'prim)
475 (case (cadr instr)
476 ((#%number?) (prim.number?))
477 ((#%+) (prim.+))
478 ((#%-) (prim.-))
479 ((#%*) (prim.*))
480 ((#%quotient) (prim.quotient))
481 ((#%remainder) (prim.remainder))
482 ((#%neg) (prim.neg))
483 ((#%=) (prim.=))
484 ((#%<) (prim.<))
485 ((#%<=) (prim.<=))
486 ((#%>) (prim.>))
487 ((#%>=) (prim.>=))
488 ((#%pair?) (prim.pair?))
489 ((#%cons) (prim.cons))
490 ((#%car) (prim.car))
491 ((#%cdr) (prim.cdr))
492 ((#%set-car!) (prim.set-car!))
493 ((#%set-cdr!) (prim.set-cdr!))
494 ((#%null?) (prim.null?))
495 ((#%eq?) (prim.eq?))
496 ((#%not) (prim.not))
497 ((#%get-cont) (prim.get-cont))
498 ((#%graft-to-cont) (prim.graft-to-cont))
499 ((#%return-to-cont) (prim.return-to-cont))
500 ((#%halt) (prim.halt))
501 ((#%symbol?) (prim.symbol?))
502 ((#%string?) (prim.string?))
503 ((#%string->list) (prim.string->list))
504 ((#%list->string) (prim.list->string))
505 ((#%make-u8vector) (prim.make-u8vector))
506 ((#%u8vector-ref) (prim.u8vector-ref))
507 ((#%u8vector-set!) (prim.u8vector-set!))
508 ((#%print) (prim.print))
509 ((#%clock) (prim.clock))
510 ((#%motor) (prim.motor))
511 ((#%led) (prim.led))
512 ((#%led2-color) (prim.led2-color))
513 ((#%getchar-wait ) (prim.getchar-wait))
514 ((#%putchar) (prim.putchar))
515 ((#%beep) (prim.beep))
516 ((#%adc) (prim.adc))
517 ((#%u8vector?) (prim.u8vector?))
518 ((#%sernum) (prim.sernum))
519 ((#%u8vector-length) (prim.u8vector-length))
520 ((#%u8vector-copy!) (prim.u8vector-copy!))
521 ((#%boolean?) (prim.boolean?))
522 ((#%network-init) (prim.network-init))
523 ((#%network-cleanup) (prim.network-cleanup))
524 ((#%receive-packet-to-u8vector) (prim.receive-packet-to-u8vector))
525 ((#%send-packet-from-u8vector) (prim.send-packet-from-u8vector))
526 ((#%ior) (prim.ior))
527 ((#%xor) (prim.xor))
528 (else
529 (compiler-error "unknown primitive" (cadr instr)))))
531 ((eq? (car instr) 'return)
532 (prim.return))
534 ((eq? (car instr) 'pop)
535 (prim.pop))
537 ((eq? (car instr) 'shift)
538 (prim.shift))
540 (else
541 (compiler-error "unknown instruction" instr)))
543 (loop2 (cdr lst)))))
545 (asm-assemble)
547 (asm-write-hex-file hex-filename)
549 (asm-end!))))))