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)
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)
32 (+ obj (- min-fixnum-encoding min-fixnum)))
36 (define (translate-constant obj)
41 (define (encode-constant obj constants)
42 (let ((o (translate-constant obj)))
43 (let ((e (encode-direct o)))
46 (let ((x (assoc o constants)))
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)))
62 (let ((x (assoc o constants)))
66 (vector-set! (cdr x) 2 (+ (vector-ref (cdr x) 2) 1)))
70 (asm-make-label 'constant)
77 (add-constants (list (car o) (cdr o))
83 (let ((chars (map char->integer (string->list o))))
84 (vector-set! descr 3 chars)
89 ((vector? o) ; ordinary vectors are stored as lists
90 (let ((elems (vector->list o)))
91 (vector-set! descr 3 elems)
97 (let ((elems (u8vector->list o)))
98 (vector-set! descr 3 elems)
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
114 (cont new-constants))))))))))
116 (define (add-constants objs constants cont)
119 (add-constant (car objs)
122 (lambda (new-constants)
123 (add-constants (cdr objs)
127 (define (add-global var globals cont)
128 (let ((x (assq var globals)))
131 ;; increment reference counter
132 (vector-set! (cdr x) 1 (+ (vector-ref (cdr x) 1) 1))
135 (cons (cons var (vector (length globals) 1))
137 (cont new-globals)))))
139 (define (sort-constants constants)
143 (> (vector-ref (cdr x) 2)
144 (vector-ref (cdr y) 2))))))
145 (let loop ((i min-rom-encoding)
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")
154 (vector-set! (cdr (car lst)) 0 i)
158 (define (sort-globals globals) ;; TODO a lot in common with sort-constants, ABSTRACT
162 (> (vector-ref (cdr x) 1)
163 (vector-ref (cdr y) 1))))))
167 (if (> i 256) ;; the number of globals is encoded on a byte
168 (compiler-error "too many global variables")
171 (vector-set! (cdr (car lst)) 0 i)
176 (lambda (code hex-filename)
177 (let loop1 ((lst code)
178 (constants (predef-constants))
179 (globals (predef-globals))
183 (let ((instr (car lst)))
184 (cond ((number? instr)
188 (cons (cons instr (asm-make-label 'label))
190 ((eq? (car instr) 'push-constant)
191 (add-constant (cadr instr)
194 (lambda (new-constants)
199 ((memq (car instr) '(push-global set-global))
200 (add-global (cadr instr)
202 (lambda (new-globals)
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)))
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
223 (let ((dist (- (asm-label-pos label) (+ self 1))))
225 (<= 0 dist 15) ;; TODO go backwards too ?
228 (let ((dist (- (asm-label-pos label) (+ self 1))))
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))))
236 (let ((dist (+ 128 (- (asm-label-pos label) (+ self 2)))))
241 (let ((dist (+ 128 (- (asm-label-pos label) (+ self 2)))))
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)))))
250 (let ((dist (+ 2048 (- (asm-label-pos label) (+ self 2)))))
255 (let ((dist (+ 2048 (- (asm-label-pos label) (+ self 2)))))
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))))
266 (let ((pos (- (asm-label-pos label) code-start)))
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)))))
272 (asm-8 (quotient pos 256))
273 (asm-8 (modulo pos 256))))))
275 (define (push-constant n)
279 (let ((key '---push-constant-1byte))
280 (let ((n (table-ref instr-table key 0)))
281 (table-set! instr-table key (+ n 1)))))
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)
293 (compiler-error "stack is too deep")
296 (define (push-global n)
300 (let ((key '---push-global-1byte))
301 (let ((n (table-ref instr-table key 0)))
302 (table-set! instr-table key (+ n 1)))))
306 (let ((key '---push-global-2bytes))
307 (let ((n (table-ref instr-table key 0)))
308 (table-set! instr-table key (+ n 1)))))
312 (define (set-global n)
316 (let ((key '---set-global-1byte))
317 (let ((n (table-ref instr-table key 0)))
318 (table-set! instr-table key (+ n 1)))))
322 (let ((key '---set-global-2bytes))
323 (let ((n (table-ref instr-table key 0)))
324 (table-set! instr-table key (+ n 1)))))
330 (compiler-error "call has too many arguments")
335 (compiler-error "call has too many arguments")
338 (define optimize! #f);;;;;;;;;;;;;;;;;;;;;
339 ; (define optimize! 0);;;;;;;;;;;;;;;;;;;;;
341 (define (call-toplevel label)
344 #xb5 ;; saves 60, 78 (71)
345 #f ;; saves 150, 168 (161)
349 (define (jump-toplevel label)
351 #x80 ;; saves 62 (62)
352 #xb6 ;; saves 45, 76 (76)
353 #f ;; saves 67, 98 (98)
360 #xb7 ;; saves 21, 21 (22)
361 #f ;; saves 30, 30 (31)
365 (define (goto-if-false label)
367 #x90 ;; saves 54 (44)
368 #xb8 ;; saves 83, 110 (105)
369 #f ;; saves 109, 136 (131)
373 (define (closure label)
376 #f ;; #xb9 ;; #f;; does not work!!! #xb9 ;; saves 27, 52 (51) TODO
377 #f ;; saves 34, 59 (58)
384 (define (prim.number?) (prim 0))
385 (define (prim.+) (prim 1))
386 (define (prim.-) (prim 2))
387 (define (prim.*) (prim 3))
388 (define (prim.quotient) (prim 4))
389 (define (prim.remainder) (prim 5))
390 (define (prim.neg) (prim 6))
391 (define (prim.=) (prim 7))
392 (define (prim.<) (prim 8))
393 (define (prim.>) (prim 10))
394 (define (prim.pair?) (prim 12))
395 (define (prim.cons) (prim 13))
396 (define (prim.car) (prim 14))
397 (define (prim.cdr) (prim 15))
398 (define (prim.set-car!) (prim 16))
399 (define (prim.set-cdr!) (prim 17))
400 (define (prim.null?) (prim 18))
401 (define (prim.eq?) (prim 19))
402 (define (prim.not) (prim 20))
403 (define (prim.get-cont) (prim 21))
404 (define (prim.graft-to-cont) (prim 22))
405 (define (prim.return-to-cont) (prim 23))
406 (define (prim.halt) (prim 24))
407 (define (prim.symbol?) (prim 25))
408 (define (prim.string?) (prim 26))
409 (define (prim.string->list) (prim 27))
410 (define (prim.list->string) (prim 28))
411 (define (prim.make-u8vector) (prim 29))
412 (define (prim.u8vector-ref) (prim 30))
413 (define (prim.u8vector-set!) (prim 31))
414 (define (prim.print) (prim 32))
415 (define (prim.clock) (prim 33))
416 (define (prim.motor) (prim 34))
417 (define (prim.led) (prim 35))
418 (define (prim.led2-color) (prim 36))
419 (define (prim.getchar-wait) (prim 37))
420 (define (prim.putchar) (prim 38))
421 (define (prim.beep) (prim 39))
422 (define (prim.adc) (prim 40))
423 (define (prim.u8vector?) (prim 41))
424 (define (prim.sernum) (prim 42))
425 (define (prim.u8vector-length) (prim 43))
426 (define (prim.shift) (prim 45))
427 (define (prim.pop) (prim 46))
428 (define (prim.return) (prim 47))
429 (define (prim.boolean?) (prim 48))
430 (define (prim.network-init) (prim 49))
431 (define (prim.network-cleanup) (prim 50))
432 (define (prim.receive-packet-to-u8vector) (prim 51))
433 (define (prim.send-packet-from-u8vector) (prim 52))
434 (define (prim.ior) (prim 53))
435 (define (prim.xor) (prim 54))
437 (define big-endian? #f)
440 (define instr-table (make-table))
442 (asm-begin! code-start #f)
446 (asm-8 (length constants))
447 (asm-8 (length globals))
449 '(pp (list constants: constants globals: globals))
453 (let* ((descr (cdr x))
454 (label (vector-ref descr 1))
457 ;; see the vm source for a description of encodings
458 ;; TODO have comments here to explain encoding, at least magic number that give the type
459 (cond ((and (integer? obj) (exact? obj))
460 (let ((hi (encode-constant (vector-ref descr 3)
462 ; (pp (list ENCODE: (vector-ref descr 3) to: hi lo: obj))
463 (asm-8 (+ 0 (arithmetic-shift hi -8))) ;; TODO -5 has low 16 at 00fb, should be fffb, 8 bits ar lost
464 (asm-8 (bitwise-and hi #xff)) ; pointer to hi
465 (asm-8 (arithmetic-shift obj -8)) ; bits 8-15
466 (asm-8 (bitwise-and obj #xff)))) ; bits 0-7
468 (let ((obj-car (encode-constant (car obj) constants))
469 (obj-cdr (encode-constant (cdr obj) constants)))
470 (asm-8 (+ #x80 (arithmetic-shift obj-car -8)))
471 (asm-8 (bitwise-and obj-car #xff))
472 (asm-8 (+ 0 (arithmetic-shift obj-cdr -8)))
473 (asm-8 (bitwise-and obj-cdr #xff))))
480 (let ((obj-enc (encode-constant (vector-ref descr 3)
482 (asm-8 (+ #x80 (arithmetic-shift obj-enc -8)))
483 (asm-8 (bitwise-and obj-enc #xff))
486 ((vector? obj) ; ordinary vectors are stored as lists
487 (let* ((elems (vector-ref descr 3))
488 (obj-car (encode-constant (car elems)
490 (obj-cdr (encode-constant (cdr elems)
492 (asm-8 (+ #x80 (arithmetic-shift obj-car -8)))
493 (asm-8 (bitwise-and obj-car #xff))
494 (asm-8 (+ 0 (arithmetic-shift obj-cdr -8)))
495 (asm-8 (bitwise-and obj-cdr #xff))))
497 (let ((obj-enc (encode-constant (vector-ref descr 3)
499 (l (length (vector-ref descr 3))))
500 ;; length is stored raw, not encoded as an object
501 ;; however, the bytes of content are encoded as
503 (asm-8 (+ #x80 (arithmetic-shift l -8)))
504 (asm-8 (bitwise-and l #xff))
505 (asm-8 (+ #x60 (arithmetic-shift obj-enc -8)))
506 (asm-8 (bitwise-and obj-enc #xff))))
508 (compiler-error "unknown object type" obj)))))
511 ;;(pp code);;;;;;;;;;;;
513 (let loop2 ((lst code))
515 (let ((instr (car lst)))
518 (if (not (number? instr))
519 (let ((key (car instr)))
520 (let ((n (table-ref instr-table key 0)))
521 (table-set! instr-table key (+ n 1))))))
523 (cond ((number? instr)
524 (let ((label (cdr (assq instr labels))))
527 ((eq? (car instr) 'entry)
528 (let ((np (cadr instr))
529 (rest? (caddr instr)))
530 (asm-8 (if rest? (- np) np))))
532 ((eq? (car instr) 'push-constant)
533 (let ((n (encode-constant (cadr instr) constants)))
536 ((eq? (car instr) 'push-stack)
537 (push-stack (cadr instr)))
539 ((eq? (car instr) 'push-global)
540 (push-global (vector-ref
541 (cdr (assq (cadr instr) globals))
544 ((eq? (car instr) 'set-global)
545 (set-global (vector-ref
546 (cdr (assq (cadr instr) globals))
549 ((eq? (car instr) 'call)
552 ((eq? (car instr) 'jump)
555 ((eq? (car instr) 'call-toplevel)
556 (let ((label (cdr (assq (cadr instr) labels))))
557 (call-toplevel label)))
559 ((eq? (car instr) 'jump-toplevel)
560 (let ((label (cdr (assq (cadr instr) labels))))
561 (jump-toplevel label)))
563 ((eq? (car instr) 'goto)
564 (let ((label (cdr (assq (cadr instr) labels))))
567 ((eq? (car instr) 'goto-if-false)
568 (let ((label (cdr (assq (cadr instr) labels))))
569 (goto-if-false label)))
571 ((eq? (car instr) 'closure)
572 (let ((label (cdr (assq (cadr instr) labels))))
575 ((eq? (car instr) 'prim)
577 ((#%number?) (prim.number?))
581 ((#%quotient) (prim.quotient))
582 ((#%remainder) (prim.remainder))
587 ((#%pair?) (prim.pair?))
588 ((#%cons) (prim.cons))
591 ((#%set-car!) (prim.set-car!))
592 ((#%set-cdr!) (prim.set-cdr!))
593 ((#%null?) (prim.null?))
596 ((#%get-cont) (prim.get-cont))
597 ((#%graft-to-cont) (prim.graft-to-cont))
598 ((#%return-to-cont) (prim.return-to-cont))
599 ((#%halt) (prim.halt))
600 ((#%symbol?) (prim.symbol?))
601 ((#%string?) (prim.string?))
602 ((#%string->list) (prim.string->list))
603 ((#%list->string) (prim.list->string))
604 ((#%make-u8vector) (prim.make-u8vector))
605 ((#%u8vector-ref) (prim.u8vector-ref))
606 ((#%u8vector-set!) (prim.u8vector-set!))
607 ((#%print) (prim.print))
608 ((#%clock) (prim.clock))
609 ((#%motor) (prim.motor))
611 ((#%led2-color) (prim.led2-color))
612 ((#%getchar-wait ) (prim.getchar-wait))
613 ((#%putchar) (prim.putchar))
614 ((#%beep) (prim.beep))
616 ((#%u8vector?) (prim.u8vector?))
617 ((#%sernum) (prim.sernum))
618 ((#%u8vector-length) (prim.u8vector-length))
619 ((#%boolean?) (prim.boolean?))
620 ((#%network-init) (prim.network-init))
621 ((#%network-cleanup) (prim.network-cleanup))
622 ((#%receive-packet-to-u8vector) (prim.receive-packet-to-u8vector))
623 ((#%send-packet-from-u8vector) (prim.send-packet-from-u8vector))
627 (compiler-error "unknown primitive" (cadr instr)))))
629 ((eq? (car instr) 'return)
632 ((eq? (car instr) 'pop)
635 ((eq? (car instr) 'shift)
639 (compiler-error "unknown instruction" instr)))
647 (sort-list (table->list instr-table)
648 (lambda (x y) (> (cdr x) (cdr y))))))
650 ;;;;;;;;; (asm-display-listing ##stdout-port);;;;;;;;;;;;;
651 (asm-write-hex-file hex-filename)