| blob | a0da6bcef47f699a9e9dcf2c49c552810d2ed025 |
1 ;;;; File: "encoding.scm", Time-stamp: <2009-08-22 14:39:05 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-rel4 opcode-rel8 opcode-rel12 opcode-abs16 opcode-sym)
217 ;;;;;;;;;;;;;;;;; (if (eq? opcode-sym 'goto) (pp (list 'goto label)))
218 (asm-at-assembly
219 ;; if the distance from pc to the label fits in a single byte,
220 ;; a short instruction is used, containing a relative address
221 ;; if not, the full 16-bit label is used
222 (lambda (self)
223 (let ((dist (- (asm-label-pos label) (+ self 1))))
224 (and opcode-rel4
225 (<= 0 dist 15) ;; TODO go backwards too ?
226 1)))
227 (lambda (self)
228 (let ((dist (- (asm-label-pos label) (+ self 1))))
229 (if stats?
230 (let ((key (list '---rel-4bit opcode-sym)))
231 (let ((n (table-ref instr-table key 0)))
232 (table-set! instr-table key (+ n 1)))))
233 (asm-8 (+ opcode-rel4 dist))))
235 (lambda (self)
236 (let ((dist (+ 128 (- (asm-label-pos label) (+ self 2)))))
237 (and opcode-rel8
238 (<= 0 dist 255)
239 2)))
240 (lambda (self)
241 (let ((dist (+ 128 (- (asm-label-pos label) (+ self 2)))))
242 (if stats?
243 (let ((key (list '---rel-8bit opcode-sym)))
244 (let ((n (table-ref instr-table key 0)))
245 (table-set! instr-table key (+ n 1)))))
246 (asm-8 opcode-rel8)
247 (asm-8 dist)))
249 (lambda (self)
250 (let ((dist (+ 2048 (- (asm-label-pos label) (+ self 2)))))
251 (and opcode-rel12
252 (<= 0 dist 4095)
253 2)))
254 (lambda (self)
255 (let ((dist (+ 2048 (- (asm-label-pos label) (+ self 2)))))
256 (if stats?
257 (let ((key (list '---rel-12bit opcode-sym)))
258 (let ((n (table-ref instr-table key 0)))
259 (table-set! instr-table key (+ n 1)))))
260 (asm-8 (+ opcode-rel12 (quotient dist 256)))
261 (asm-8 (modulo dist 256))))
263 (lambda (self)
264 3)
265 (lambda (self)
266 (let ((pos (- (asm-label-pos label) code-start)))
267 (if stats?
268 (let ((key (list '---abs-16bit opcode-sym)))
269 (let ((n (table-ref instr-table key 0)))
270 (table-set! instr-table key (+ n 1)))))
271 (asm-8 opcode-abs16)
272 (asm-8 (quotient pos 256))
273 (asm-8 (modulo pos 256))))))
275 (define (push-constant n)
276 (if (<= n 31)
277 (begin
278 (if stats?
279 (let ((key '---push-constant-1byte))
280 (let ((n (table-ref instr-table key 0)))
281 (table-set! instr-table key (+ n 1)))))
282 (asm-8 (+ #x00 n)))
283 (begin
284 (if stats?
285 (let ((key '---push-constant-2bytes))
286 (let ((n (table-ref instr-table key 0)))
287 (table-set! instr-table key (+ n 1)))))
288 (asm-8 (+ #xa0 (quotient n 256)))
289 (asm-8 (modulo n 256)))))
291 (define (push-stack n)
292 (if (> n 31)
293 (compiler-error "stack is too deep")
294 (asm-8 (+ #x20 n))))
296 (define (push-global n)
297 (if (<= n 15)
298 (begin
299 (if stats?
300 (let ((key '---push-global-1byte))
301 (let ((n (table-ref instr-table key 0)))
302 (table-set! instr-table key (+ n 1)))))
303 (asm-8 (+ #x40 n)))
304 (begin
305 (if stats?
306 (let ((key '---push-global-2bytes))
307 (let ((n (table-ref instr-table key 0)))
308 (table-set! instr-table key (+ n 1)))))
309 (asm-8 #x8e)
310 (asm-8 n))))
312 (define (set-global n)
313 (if (<= n 15)
314 (begin
315 (if stats?
316 (let ((key '---set-global-1byte))
317 (let ((n (table-ref instr-table key 0)))
318 (table-set! instr-table key (+ n 1)))))
319 (asm-8 (+ #x50 n)))
320 (begin
321 (if stats?
322 (let ((key '---set-global-2bytes))
323 (let ((n (table-ref instr-table key 0)))
324 (table-set! instr-table key (+ n 1)))))
325 (asm-8 #x8f)
326 (asm-8 n))))
328 (define (call n)
329 (if (> n 15)
330 (compiler-error "call has too many arguments")
331 (asm-8 (+ #x60 n))))
333 (define (jump n)
334 (if (> n 15)
335 (compiler-error "call has too many arguments")
336 (asm-8 (+ #x70 n))))
338 (define optimize! #f);;;;;;;;;;;;;;;;;;;;;
339 ; (define optimize! 0);;;;;;;;;;;;;;;;;;;;;
341 (define (call-toplevel label)
342 (label-instr label
343 #f ;; saves 36 (22)
344 #xb5 ;; saves 60, 78 (71)
345 #f ;; saves 150, 168 (161)
346 #xb0
347 'call-toplevel))
349 (define (jump-toplevel label)
350 (label-instr label
351 #x80 ;; saves 62 (62)
352 #xb6 ;; saves 45, 76 (76)
353 #f ;; saves 67, 98 (98)
354 #xb1
355 'jump-toplevel))
357 (define (goto label)
358 (label-instr label
359 #f ;; saves 0 (2)
360 #xb7 ;; saves 21, 21 (22)
361 #f ;; saves 30, 30 (31)
362 #xb2
363 'goto))
365 (define (goto-if-false label)
366 (label-instr label
367 #x90 ;; saves 54 (44)
368 #xb8 ;; saves 83, 110 (105)
369 #f ;; saves 109, 136 (131)
370 #xb3
371 'goto-if-false))
373 (define (closure label)
374 (label-instr label
375 #f ;; saves 50 (48)
376 #f ;; #xb9 ;; #f;; does not work!!! #xb9 ;; saves 27, 52 (51) TODO
377 #f ;; saves 34, 59 (58)
378 #xb4
379 'closure))
381 (define (prim n)
382 (asm-8 (+ #xc0 n)))
384 (define (prim.number?) (prim 0))
385 (define (prim.+) (prim 1))
386 (define (prim.-) (prim 2))
387 (define (prim.mul-non-neg) (prim 3))
388 (define (prim.quotient) (prim 4))
389 (define (prim.remainder) (prim 5))
390 (define (prim.=) (prim 7))
391 (define (prim.<) (prim 8))
392 (define (prim.>) (prim 10))
393 (define (prim.pair?) (prim 12))
394 (define (prim.cons) (prim 13))
395 (define (prim.car) (prim 14))
396 (define (prim.cdr) (prim 15))
397 (define (prim.set-car!) (prim 16))
398 (define (prim.set-cdr!) (prim 17))
399 (define (prim.null?) (prim 18))
400 (define (prim.eq?) (prim 19))
401 (define (prim.not) (prim 20))
402 (define (prim.get-cont) (prim 21))
403 (define (prim.graft-to-cont) (prim 22))
404 (define (prim.return-to-cont) (prim 23))
405 (define (prim.halt) (prim 24))
406 (define (prim.symbol?) (prim 25))
407 (define (prim.string?) (prim 26))
408 (define (prim.string->list) (prim 27))
409 (define (prim.list->string) (prim 28))
410 (define (prim.make-u8vector) (prim 29))
411 (define (prim.u8vector-ref) (prim 30))
412 (define (prim.u8vector-set!) (prim 31))
413 (define (prim.print) (prim 32))
414 (define (prim.clock) (prim 33))
415 (define (prim.motor) (prim 34))
416 (define (prim.led) (prim 35))
417 (define (prim.led2-color) (prim 36))
418 (define (prim.getchar-wait) (prim 37))
419 (define (prim.putchar) (prim 38))
420 (define (prim.beep) (prim 39))
421 (define (prim.adc) (prim 40))
422 (define (prim.u8vector?) (prim 41))
423 (define (prim.sernum) (prim 42))
424 (define (prim.u8vector-length) (prim 43))
425 (define (prim.shift) (prim 45))
426 (define (prim.pop) (prim 46))
427 (define (prim.return) (prim 47))
428 (define (prim.boolean?) (prim 48))
429 (define (prim.network-init) (prim 49))
430 (define (prim.network-cleanup) (prim 50))
431 (define (prim.receive-packet-to-u8vector) (prim 51))
432 (define (prim.send-packet-from-u8vector) (prim 52))
433 (define (prim.ior) (prim 53))
434 (define (prim.xor) (prim 54))
436 (define big-endian? #f)
438 (define stats? #t)
439 (define instr-table (make-table))
441 (asm-begin! code-start #f)
443 (asm-8 #xfb)
444 (asm-8 #xd7)
445 (asm-8 (length constants))
446 (asm-8 (length globals))
448 '(pp (list constants: constants globals: globals))
450 (for-each
451 (lambda (x)
452 (let* ((descr (cdr x))
453 (label (vector-ref descr 1))
454 (obj (car x)))
455 (asm-label label)
456 ;; see the vm source for a description of encodings
457 ;; TODO have comments here to explain encoding, at least magic number that give the type
458 (cond ((and (integer? obj) (exact? obj))
459 (let ((hi (encode-constant (vector-ref descr 3)
460 constants)))
461 ; (pp (list ENCODE: (vector-ref descr 3) to: hi lo: obj))
462 (asm-8 (+ 0 (arithmetic-shift hi -8))) ;; TODO -5 has low 16 at 00fb, should be fffb, 8 bits ar lost
463 (asm-8 (bitwise-and hi #xff)) ; pointer to hi
464 (asm-8 (arithmetic-shift obj -8)) ; bits 8-15
465 (asm-8 (bitwise-and obj #xff)))) ; bits 0-7
466 ((pair? obj)
467 (let ((obj-car (encode-constant (car obj) constants))
468 (obj-cdr (encode-constant (cdr obj) constants)))
469 (asm-8 (+ #x80 (arithmetic-shift obj-car -8)))
470 (asm-8 (bitwise-and obj-car #xff))
471 (asm-8 (+ 0 (arithmetic-shift obj-cdr -8)))
472 (asm-8 (bitwise-and obj-cdr #xff))))
473 ((symbol? obj)
474 (asm-8 #x80)
475 (asm-8 0)
476 (asm-8 #x20)
477 (asm-8 0))
478 ((string? obj)
479 (let ((obj-enc (encode-constant (vector-ref descr 3)
480 constants)))
481 (asm-8 (+ #x80 (arithmetic-shift obj-enc -8)))
482 (asm-8 (bitwise-and obj-enc #xff))
483 (asm-8 #x40)
484 (asm-8 0)))
485 ((vector? obj) ; ordinary vectors are stored as lists
486 (let* ((elems (vector-ref descr 3))
487 (obj-car (encode-constant (car elems)
488 constants))
489 (obj-cdr (encode-constant (cdr elems)
490 constants)))
491 (asm-8 (+ #x80 (arithmetic-shift obj-car -8)))
492 (asm-8 (bitwise-and obj-car #xff))
493 (asm-8 (+ 0 (arithmetic-shift obj-cdr -8)))
494 (asm-8 (bitwise-and obj-cdr #xff))))
495 ((u8vector? obj)
496 (let ((obj-enc (encode-constant (vector-ref descr 3)
497 constants))
498 (l (length (vector-ref descr 3))))
499 ;; length is stored raw, not encoded as an object
500 ;; however, the bytes of content are encoded as
501 ;; fixnums
502 (asm-8 (+ #x80 (arithmetic-shift l -8)))
503 (asm-8 (bitwise-and l #xff))
504 (asm-8 (+ #x60 (arithmetic-shift obj-enc -8)))
505 (asm-8 (bitwise-and obj-enc #xff))))
506 (else
507 (compiler-error "unknown object type" obj)))))
508 constants)
510 ;;(pp code);;;;;;;;;;;;
512 (let loop2 ((lst code))
513 (if (pair? lst)
514 (let ((instr (car lst)))
516 (if stats?
517 (if (not (number? instr))
518 (let ((key (car instr)))
519 (let ((n (table-ref instr-table key 0)))
520 (table-set! instr-table key (+ n 1))))))
522 (cond ((number? instr)
523 (let ((label (cdr (assq instr labels))))
524 (asm-label label)))
526 ((eq? (car instr) 'entry)
527 (let ((np (cadr instr))
528 (rest? (caddr instr)))
529 (asm-8 (if rest? (- np) np))))
531 ((eq? (car instr) 'push-constant)
532 (let ((n (encode-constant (cadr instr) constants)))
533 (push-constant n)))
535 ((eq? (car instr) 'push-stack)
536 (push-stack (cadr instr)))
538 ((eq? (car instr) 'push-global)
539 (push-global (vector-ref
540 (cdr (assq (cadr instr) globals))
541 0)))
543 ((eq? (car instr) 'set-global)
544 (set-global (vector-ref
545 (cdr (assq (cadr instr) globals))
546 0)))
548 ((eq? (car instr) 'call)
549 (call (cadr instr)))
551 ((eq? (car instr) 'jump)
552 (jump (cadr instr)))
554 ((eq? (car instr) 'call-toplevel)
555 (let ((label (cdr (assq (cadr instr) labels))))
556 (call-toplevel label)))
558 ((eq? (car instr) 'jump-toplevel)
559 (let ((label (cdr (assq (cadr instr) labels))))
560 (jump-toplevel label)))
562 ((eq? (car instr) 'goto)
563 (let ((label (cdr (assq (cadr instr) labels))))
564 (goto label)))
566 ((eq? (car instr) 'goto-if-false)
567 (let ((label (cdr (assq (cadr instr) labels))))
568 (goto-if-false label)))
570 ((eq? (car instr) 'closure)
571 (let ((label (cdr (assq (cadr instr) labels))))
572 (closure label)))
574 ((eq? (car instr) 'prim)
575 (case (cadr instr)
576 ((#%number?) (prim.number?))
577 ((#%+) (prim.+))
578 ((#%-) (prim.-))
579 ((#%mul-non-neg) (prim.mul-non-neg))
580 ((#%quotient) (prim.quotient))
581 ((#%remainder) (prim.remainder))
582 ((#%=) (prim.=))
583 ((#%<) (prim.<))
584 ((#%>) (prim.>))
585 ((#%pair?) (prim.pair?))
586 ((#%cons) (prim.cons))
587 ((#%car) (prim.car))
588 ((#%cdr) (prim.cdr))
589 ((#%set-car!) (prim.set-car!))
590 ((#%set-cdr!) (prim.set-cdr!))
591 ((#%null?) (prim.null?))
592 ((#%eq?) (prim.eq?))
593 ((#%not) (prim.not))
594 ((#%get-cont) (prim.get-cont))
595 ((#%graft-to-cont) (prim.graft-to-cont))
596 ((#%return-to-cont) (prim.return-to-cont))
597 ((#%halt) (prim.halt))
598 ((#%symbol?) (prim.symbol?))
599 ((#%string?) (prim.string?))
600 ((#%string->list) (prim.string->list))
601 ((#%list->string) (prim.list->string))
602 ((#%make-u8vector) (prim.make-u8vector))
603 ((#%u8vector-ref) (prim.u8vector-ref))
604 ((#%u8vector-set!) (prim.u8vector-set!))
605 ((#%print) (prim.print))
606 ((#%clock) (prim.clock))
607 ((#%motor) (prim.motor))
608 ((#%led) (prim.led))
609 ((#%led2-color) (prim.led2-color))
610 ((#%getchar-wait ) (prim.getchar-wait))
611 ((#%putchar) (prim.putchar))
612 ((#%beep) (prim.beep))
613 ((#%adc) (prim.adc))
614 ((#%u8vector?) (prim.u8vector?))
615 ((#%sernum) (prim.sernum))
616 ((#%u8vector-length) (prim.u8vector-length))
617 ((#%boolean?) (prim.boolean?))
618 ((#%network-init) (prim.network-init))
619 ((#%network-cleanup) (prim.network-cleanup))
620 ((#%receive-packet-to-u8vector) (prim.receive-packet-to-u8vector))
621 ((#%send-packet-from-u8vector) (prim.send-packet-from-u8vector))
622 ((#%ior) (prim.ior))
623 ((#%xor) (prim.xor))
624 (else
625 (compiler-error "unknown primitive" (cadr instr)))))
627 ((eq? (car instr) 'return)
628 (prim.return))
630 ((eq? (car instr) 'pop)
631 (prim.pop))
633 ((eq? (car instr) 'shift)
634 (prim.shift))
636 (else
637 (compiler-error "unknown instruction" instr)))
639 (loop2 (cdr lst)))))
641 (asm-assemble)
643 (if stats?
644 (pretty-print
645 (sort-list (table->list instr-table)
646 (lambda (x y) (> (cdr x) (cdr y))))))
648 ;;;;;;;;; (asm-display-listing ##stdout-port);;;;;;;;;;;;;
649 (asm-write-hex-file hex-filename)
651 (asm-end!))))))