| blob | 3ebabbded7141a67754d7018d941f553d41a8ac0 |
1 ;;; File: "pic18-sim.scm"
3 (define pic18-ram #f)
4 (define pic18-rom #f)
5 (define pic18-stack #f)
6 (define pic18-pc #f)
8 (define instrs-counts #f) ; counts how many times each instruction is executed
9 (define break-points '()) ; list of adresses at which the simulation stops
11 (define pic18-carry-flag #f)
12 (define pic18-deccarry-flag #f)
13 (define pic18-zero-flag #f)
14 (define pic18-overflow-flag #f)
15 (define pic18-negative-flag #f)
17 (define pic18-cycles #f)
18 (define pic18-exit #f)
20 (define fsr-alist (list (cons INDF0 (cons FSR0H FSR0L))
21 (cons INDF1 (cons FSR1H FSR1L))
22 (cons INDF2 (cons FSR2H FSR2L))))
24 (define (get-ram adr) ;; TODO implement RCREG
25 (cond ((= adr TOSU)
26 (bitwise-and (arithmetic-shift (get-tos) -16) #xff))
27 ((= adr TOSH)
28 (bitwise-and (arithmetic-shift (get-tos) -8) #xff))
29 ((= adr TOSL)
30 (bitwise-and (get-tos) #xff))
31 ((= adr PCL)
32 (set-ram PCLATU (bitwise-and (arithmetic-shift (get-pc) -16) #x1f))
33 (set-ram PCLATH (bitwise-and (arithmetic-shift (get-pc) -8) #xff))
34 (bitwise-and (get-pc) #xfe))
35 ((= adr STATUS)
36 (+ pic18-carry-flag
37 (arithmetic-shift pic18-deccarry-flag 1)
38 (arithmetic-shift pic18-zero-flag 2)
39 (arithmetic-shift pic18-overflow-flag 3)
40 (arithmetic-shift pic18-negative-flag 4)))
41 ((assq adr fsr-alist)
42 => (lambda (x)
43 (get-ram (bitwise-ior
44 (arithmetic-shift (bitwise-and (u8vector-ref pic18-ram
45 (cadr x))
46 #xf)
47 8)
48 (u8vector-ref pic18-ram
49 (cddr x))))))
50 ;; TODO pre/post inc/dec 0..2
51 (else
52 (u8vector-ref pic18-ram adr))))
54 (define (set-ram adr byte)
55 (cond ((= adr TOSU)
56 (set-tos (+ (bitwise-and (get-tos) #x00ffff)
57 (arithmetic-shift (bitwise-and byte #x1f) 16))))
58 ((= adr TOSH)
59 (set-tos (+ (bitwise-and (get-tos) #x1f00ff)
60 (arithmetic-shift byte 8))))
61 ((= adr TOSL)
62 (set-tos (+ (bitwise-and (get-tos) #x1fff00)
63 byte)))
64 ((= adr PCL)
65 (set-pc (+ (arithmetic-shift (get-ram PCLATU) 16)
66 (arithmetic-shift (get-ram PCLATH) 8)
67 (bitwise-and byte #xfe))))
68 ((= adr TXREG)
69 (display (list->string (list (integer->char byte)))))
70 ((= adr STATUS)
71 (set! pic18-carry-flag (bitwise-and byte 1))
72 (set! pic18-deccarry-flag (arithmetic-shift (bitwise-and byte 2) -1))
73 (set! pic18-zero-flag (arithmetic-shift (bitwise-and byte 4) -2))
74 (set! pic18-overflow-flag (arithmetic-shift (bitwise-and byte 8) -3))
75 (set! pic18-negative-flag (arithmetic-shift (bitwise-and byte 16) -4)))
76 ((assq adr fsr-alist)
77 => (lambda (x)
78 (set-ram (bitwise-ior ;; TODO factor common code with get-ram ?
79 (arithmetic-shift (bitwise-and (u8vector-ref pic18-ram
80 (cadr x))
81 #xf)
82 8)
83 (u8vector-ref pic18-ram
84 (cddr x)))
85 byte)))
86 ;; TODO all other special array registers
87 (else
88 (u8vector-set! pic18-ram adr byte))))
90 (define (get-rom adr)
91 (u8vector-ref pic18-rom adr))
93 (define (set-rom adr byte)
94 (u8vector-set! pic18-rom adr byte))
96 (define (get-stack adr)
97 (vector-ref pic18-stack adr))
99 (define (set-stack adr pc)
100 (vector-set! pic18-stack adr pc))
102 (define (get-pc)
103 pic18-pc)
105 (define (set-pc pc)
106 (set! pic18-pc pc))
108 (define (get-sp)
109 (bitwise-and (get-ram STKPTR) #x1f))
111 (define (set-sp sp)
112 (set-ram STKPTR
113 (bitwise-ior sp
114 (bitwise-and (get-ram STKPTR) #xe0))))
116 (define (get-tos)
117 (vector-ref pic18-stack (- (get-sp) 1)))
119 (define (set-tos pc)
120 (vector-set! pic18-stack (- (get-sp) 1) pc))
122 (define (stack-push pc)
123 (set-sp (+ (get-sp) 1))
124 (set-tos pc))
126 (define (stack-pop)
127 (set-pc (get-tos))
128 (set-sp (- (get-sp) 1)))
130 (define (get-bsr)
131 (bitwise-and (get-ram BSR) #x0f))
133 (define (get-wreg)
134 (get-ram WREG))
136 (define (set-wreg byte)
137 (set-ram WREG byte))
139 (define (zero-flag?)
140 (not (= 0 pic18-zero-flag)))
142 (define (set-zero-flag flag)
143 (set! pic18-zero-flag flag))
145 (define (negative-flag?)
146 (not (= 0 pic18-negative-flag)))
148 (define (set-negative-flag flag)
149 (set! pic18-negative-flag flag))
151 (define (carry-flag?)
152 (not (= 0 pic18-carry-flag)))
154 (define (set-carry-flag flag)
155 (set! pic18-carry-flag flag))
157 (define (deccarry-flag?)
158 (not (= 0 pic18-deccarry-flag)))
160 (define (set-deccarry-flag flag)
161 (set! pic18-deccarry-flag flag))
163 (define (overflow-flag?)
164 (not (= 0 pic18-overflow-flag)))
166 (define (set-overflow-flag flag)
167 (set! pic18-overflow-flag flag))
169 (define (pic18-sim-setup)
170 (set! pic18-ram (make-u8vector #x1000 0))
171 (set! pic18-rom (make-u8vector #x10000 0))
172 (set! pic18-stack (make-vector #x1f 0))
173 (set! instrs-counts (make-vector #x10000 0))
174 (set-pc 0)
175 (set-wreg 0)
176 (set! pic18-carry-flag 0)
177 (set! pic18-deccarry-flag 0)
178 (set! pic18-zero-flag 0)
179 (set! pic18-overflow-flag 0)
180 (set! pic18-negative-flag 0))
182 (define (pic18-sim-cleanup)
183 (set! pic18-ram #f)
184 (set! pic18-rom #f)
185 (set! pic18-stack #f))
187 ;------------------------------------------------------------------------------
189 (define (last-pc)
190 (let ((pc (- (get-pc) 2)))
191 (list (get-sp) " " (- pic18-cycles 1) " "
192 (substring (number->string (+ #x1000000 pc) 16) 1 7)
193 " ")))
195 (define (illegal-opcode opcode)
196 (if trace-instr
197 (print (list (last-pc) " *illegal*")))
198 (error "illegal opcode" opcode))
200 (define decode-vector
201 (make-vector 256 illegal-opcode))
203 (define (decode-opcode opcode-bits shift action)
204 (if (< shift 8)
205 (error "shift=" shift))
206 (let ((n (arithmetic-shift 1 (- shift 8)))
207 (base (arithmetic-shift opcode-bits (- shift 8))))
208 (let loop ((i 0))
209 (if (< i n)
210 (begin
211 (vector-set! decode-vector (+ base i) action)
212 (loop (+ i 1)))))))
214 (define (byte-oriented opcode mnemonic flags-changed operation)
215 (byte-oriented-aux opcode mnemonic flags-changed operation 'wreg))
216 (define (byte-oriented-file opcode mnemonic flags-changed operation)
217 (byte-oriented-aux opcode mnemonic flags-changed operation 'file))
218 (define (byte-oriented-wide opcode mnemonic flags-changed operation dest)
219 ;; for use with instructions that have results more than a byte wide, such
220 ;; as multiplication. the result goes at the given addresses
221 (byte-oriented-aux opcode mnemonic flags-changed operation dest)) ;; TODO do the same for literals
223 (define (byte-oriented-aux opcode mnemonic flags-changed operation dest)
224 (let* ((f (bitwise-and opcode #xff))
225 (adr (if (= 0 (bitwise-and opcode #x100))
226 ;; the upper 160 addresses of the first bank are the special
227 ;; registers #xF60 to #xFFF
228 (if (= 0 (bitwise-and f #x80)) f (+ f #xf00))
229 (+ f (arithmetic-shift (get-bsr) 8)))))
230 (if trace-instr
231 (print (list (last-pc) " " mnemonic " "
232 (let ((x (assv adr file-reg-names)))
233 (if x
234 (cdr x)
235 (let ((x (table-ref register-table f #f)))
236 (if #f ;x ;; TODO unreadable with picobit
237 (apply string-append-with-separator (cons "/" x))
238 (list "0x" (number->string adr 16))))))
239 (if (or (eq? dest 'wreg)
240 (= 0 (bitwise-and opcode #x200)))
241 ", w"
242 "")
243 "")))
244 (let* ((result (operation (get-ram adr)))
245 (result-8bit (bitwise-and result #xff)))
246 (cond ((list? dest)
247 ;; result is more than a byte wide (i.e. multiplication)
248 ;; put it in the right destinations (dest is a list of addresses)
249 (let loop ((dest dest) (result result))
250 (if (not (null? dest))
251 ;; the head of the list is the lsb
252 (begin (set-ram (car dest) (bitwise-and result #xff))
253 (loop (cdr dest) (arithmetic-shift result -8))))))
254 ((or (eq? dest 'file) (not (= 0 (bitwise-and opcode #x200))))
255 ;; the result goes in memory (file)
256 (set-ram adr result-8bit))
257 ((eq? dest 'wreg)
258 ;; result goes in wreg
259 (set-wreg result-8bit)))
260 (if (not (eq? flags-changed 'none))
261 (begin
262 (set-zero-flag (if (= 0 result-8bit) 1 0))
263 (if (not (eq? flags-changed 'z))
264 (begin
265 (set-negative-flag (if (> result-8bit #x7f) 1 0))
266 (if (not (eq? flags-changed 'z-n))
267 (begin
268 (set-carry-flag (if (or (> result #xff)
269 (< result 0))
270 1 0))
271 (if (not (eq? flags-changed 'c-z-n))
272 (begin
273 (set-deccarry-flag 0);;;;;;;;;;;;;;
274 (set-overflow-flag 0))))))))))));;;;;;;;;;;;;;
276 (define (bit-oriented opcode mnemonic operation)
277 (let* ((f (bitwise-and opcode #xff))
278 (adr (if (= 0 (bitwise-and opcode #x100))
279 (if (= 0 (bitwise-and f #x80)) f (+ f #xf00))
280 (+ f (arithmetic-shift (get-bsr) 8))))
281 (b (bitwise-and (arithmetic-shift opcode -9) 7)))
282 (if trace-instr
283 (print (list (last-pc) " " mnemonic " "
284 (let ((x (assv adr file-reg-names)))
285 (if x (cdr x) (list "0x" (number->string adr 16))))
286 ", "
287 (if (= adr STATUS)
288 (cdr (assv b '((0 . C)
289 (1 . DC)
290 (2 . Z)
291 (3 . OV)
292 (4 . N)
293 (5 . 5)
294 (6 . 6)
295 (7 . 7))))
296 b)
297 "")))
298 (let* ((result (operation (get-ram adr) b))
299 (result-8bit (bitwise-and result #xff)))
300 (set-ram adr result-8bit))))
302 (define (short-relative-branch opcode mnemonic branch)
303 (let* ((n (bitwise-and opcode #xff))
304 (adr (+ (get-pc) (* 2 (if (> n #x7f) (- n #x100) n)))))
305 (if trace-instr
306 (print (list (last-pc) " " mnemonic " "
307 (symbol->string (table-ref symbol-table adr)))))
308 (if (branch)
309 (begin
310 (get-program-mem)
311 (set-pc adr)))))
313 (define (long-relative-branch opcode mnemonic call?)
314 (let* ((n (bitwise-and opcode #x7ff))
315 (adr (+ (get-pc) (* 2 (if (> n #x3ff) (- n #x800) n)))))
316 (if trace-instr
317 (print (list (last-pc) " " mnemonic " "
318 (symbol->string (table-ref symbol-table adr)))))
319 (if call?
320 (stack-push (get-pc)))
321 (get-program-mem)
322 (set-pc adr)))
324 (define (call-branch opcode mnemonic)
325 (let ((adr (* 2 (+ (bitwise-and opcode #xff)
326 (arithmetic-shift (bitwise-and (get-program-mem) #xfff) 8)))))
327 (if trace-instr
328 (print (list (last-pc) " " mnemonic " "
329 (symbol->string (table-ref symbol-table adr))
330 (if (= 0 (bitwise-and opcode #x100))
331 ""
332 ", FAST"))))
333 (stack-push (get-pc))
334 (if (not (= 0 (bitwise-and opcode #x100)))
335 (error "call fast not implemented"))
336 (set-pc adr)))
338 (define (goto-branch opcode mnemonic)
339 (let ((adr (* 2 (+ (bitwise-and opcode #xff)
340 (arithmetic-shift (bitwise-and (get-program-mem) #xfff) 8)))))
341 (if trace-instr
342 (print (list (last-pc) " " mnemonic " "
343 (symbol->string (table-ref symbol-table adr)))))
344 (set-pc adr)))
346 (define (literal-operation opcode mnemonic flags-changed operation)
347 (let ((k (bitwise-and opcode #xff)))
348 (if trace-instr
349 (print (list (last-pc) " " mnemonic " "
350 (if (< k 10) k (list "0x" (number->string k 16))))))
351 (let* ((result (operation k))
352 (result-8bit (bitwise-and result #xff)))
353 (set-wreg result-8bit)
354 (if (not (eq? flags-changed 'none))
355 (begin
356 (set-zero-flag (if (= 0 result-8bit) 1 0))
357 (if (not (eq? flags-changed 'z))
358 (begin
359 (set-negative-flag (if (> result-8bit #x7f) 1 0))
360 (if (not (eq? flags-changed 'z-n))
361 (begin
362 (set-carry-flag (if (> result #xff) 1 0))
363 (if (not (eq? flags-changed 'c-z-n))
364 (begin
365 (set-deccarry-flag 0);;;;;;;;;;;;;;
366 (set-overflow-flag 0))))))))))));;;;;;;;;;;;;;
368 (define (program-memory-read mnemonic read-adr-fun set-adr-fun)
369 (if trace-instr
370 (print (list (last-pc) " " mnemonic " ")))
371 (let ((adr (bitwise-ior (arithmetic-shift (get-ram TBLPTRU) 16)
372 (arithmetic-shift (get-ram TBLPTRH) 8)
373 (get-ram TBLPTRL))))
374 (set-ram TABLAT (get-rom (bitwise-and (read-adr-fun adr)
375 ;; rom addresses are 21 bits wide
376 #x1fffff)))
377 (let ((new-adr (bitwise-and (set-adr-fun adr) #x1fffff)))
378 (set-ram TBLPTRU (arithmetic-shift new-adr -16))
379 (set-ram TBLPTRH (bitwise-and (arithmetic-shift new-adr -8) #xff))
380 (set-ram TBLPTRL (bitwise-and new-adr #xff)))))
382 (define (get-program-mem)
383 (set! pic18-cycles (+ pic18-cycles 1))
384 (let* ((pc (get-pc))
385 (lsb (get-rom pc))
386 (msb (get-rom (+ pc 1))))
387 (set-pc (+ (get-pc) 2))
388 (+ (arithmetic-shift msb 8) lsb)))
390 (define (skip)
391 (get-program-mem))
393 (define (hex n)
394 (substring (number->string (+ #x100 n) 16) 1 3))
396 (define (dump-mem)
398 (print " ")
399 (let loop ((i 0))
400 (if (< i 10)
401 (begin
402 (print (list (hex (u8vector-ref pic18-ram i)) " "))
403 (loop (+ i 1)))))
404 (print (list " WREG=" (hex (get-wreg)) "\n")))
406 (define single-stepping-mode? #f)
407 (define (pic18-execute)
408 (set! pic18-exit #f)
409 (set! pic18-cycles 0)
410 (if trace-instr
411 (print " "))
412 (let loop ()
413 (if trace-instr
414 (dump-mem))
415 (if pic18-exit
416 (begin
417 (print (list "WREG = d'" (get-wreg) "'\n")))
418 (let ((opcode (get-program-mem))
419 (pc (- (get-pc) 2)))
420 (vector-set! instrs-counts pc (+ (vector-ref instrs-counts pc) 1))
421 (if picobit-trace?
422 (begin (if (= pc #x48) ; picobit dispatch, might change
423 (pp (picobit-pc)))
424 (if (= pc #x72) ; later on in the dispatch
425 (begin (picobit-instruction)
426 (picobit-stack) ;; FOO now shows garbage, even though the rest seems valid, is env invalid at this point ? it's the same as at #x48
427 (picobit-continuation)
428 (display "\n")))))
429 (if (member pc break-points)
430 (begin (pp (list "break point at: " (number->string pc 16)))
431 (set! trace-instr #t)
432 (set! single-stepping-mode? #t)))
433 (if single-stepping-mode? (step))
434 (let ((proc (vector-ref decode-vector (arithmetic-shift opcode -8))))
435 (proc opcode)
436 (loop))))))
438 (define trace-instr #t)
440 (define (carry)
441 (if (> pic18-carry-flag 0)
442 (begin (set! pic18-carry-flag #f)
443 1)
444 0))
446 ;------------------------------------------------------------------------------
448 ; Byte-oriented file register operations.
450 (decode-opcode #b001001 10
451 (lambda (opcode)
452 (byte-oriented opcode "addwf" 'c-dc-z-ov-n
453 (lambda (f)
454 (+ f (get-wreg))))))
456 (decode-opcode #b001000 10
457 (lambda (opcode)
458 (byte-oriented opcode "addwfc" 'c-dc-z-ov-n
459 (lambda (f)
460 (+ f (get-wreg) (carry))))))
462 (decode-opcode #b000101 10
463 (lambda (opcode)
464 (byte-oriented opcode "andwf" 'z-n
465 (lambda (f)
466 (bitwise-and f (get-wreg))))))
468 (decode-opcode #b0110101 9
469 (lambda (opcode)
470 (byte-oriented-file opcode "clrf" 'z
471 (lambda (f)
472 0))))
474 (decode-opcode #b000111 10
475 (lambda (opcode)
476 (byte-oriented opcode "comf" 'z-n
477 (lambda (f)
478 (bitwise-not f)))))
480 (decode-opcode #b0110001 9
481 (lambda (opcode)
482 (byte-oriented-file opcode "cpfseq" 'none
483 (lambda (f)
484 (if (= f (get-wreg)) (skip))
485 f))))
487 (decode-opcode #b0110010 9
488 (lambda (opcode)
489 (byte-oriented-file opcode "cpfsgt" 'none
490 (lambda (f)
491 (if (> f (get-wreg)) (skip))
492 f))))
494 (decode-opcode #b0110000 9
495 (lambda (opcode)
496 (byte-oriented-file opcode "cpfslt" 'none
497 (lambda (f)
498 (if (< f (get-wreg)) (skip))
499 f))))
501 (decode-opcode #b000001 10
502 (lambda (opcode)
503 (byte-oriented opcode "decf" 'c-dc-z-ov-n
504 (lambda (f)
505 (- f 1)))))
507 (decode-opcode #b001011 10
508 (lambda (opcode)
509 (byte-oriented opcode "decfsz" 'none
510 (lambda (f)
511 (if (= f 1) (skip))
512 (- f 1)))))
514 (decode-opcode #b010011 10
515 (lambda (opcode)
516 (byte-oriented opcode "dcfsnz" 'none
517 (lambda (f)
518 (if (not (= f 1)) (skip))
519 (- f 1)))))
521 (decode-opcode #b001010 10
522 (lambda (opcode)
523 (byte-oriented opcode "incf" 'c-dc-z-ov-n
524 (lambda (f)
525 (+ f 1)))))
527 (decode-opcode #b001111 10
528 (lambda (opcode)
529 (byte-oriented opcode "incfsz" 'none
530 (lambda (f)
531 (if (= f #xff) (skip))
532 (+ f 1)))))
534 (decode-opcode #b010010 10
535 (lambda (opcode)
536 (byte-oriented opcode "infsnz" 'none
537 (lambda (f)
538 (if (not (= f #xff)) (skip))
539 (+ f 1)))))
541 (decode-opcode #b000100 10
542 (lambda (opcode)
543 (byte-oriented opcode "iorwf" 'z-n
544 (lambda (f)
545 (bitwise-ior f (get-wreg))))))
547 (decode-opcode #b010100 10
548 (lambda (opcode)
549 (byte-oriented opcode "movf" 'z-n
550 (lambda (f)
551 f))))
553 (decode-opcode #b1100 12
554 (lambda (opcode)
555 (let* ((src (bitwise-and opcode #xfff))
556 ;; the destination is in the second 16-bit part, need to fetch
557 (dst (bitwise-and (get-program-mem) #xfff)))
558 (if trace-instr
559 (print (list (last-pc) " movff "
560 (let ((x (assv src file-reg-names)))
561 (if x (cdr x) (list "0x" (number->string src 16))))
562 ", "
563 (let ((x (assv dst file-reg-names)))
564 (if x (cdr x) (list "0x" (number->string dst 16)))) ;; TODO printing 2 args ruins the formatting
565 "")))
566 (set-ram dst (get-ram src)))))
568 (decode-opcode #b0110111 9
569 (lambda (opcode)
570 (byte-oriented-file opcode "movwf" 'none
571 (lambda (f)
572 (get-wreg)))))
574 (decode-opcode #b0000001 9
575 (lambda (opcode)
576 (byte-oriented-wide opcode "mulwf" 'none
577 (lambda (f)
578 (* f (get-wreg)))
579 (list PRODL PRODH))))
581 (decode-opcode #b0110110 9
582 (lambda (opcode)
583 (byte-oriented-file opcode "negf" 'c-dc-z-ov-n
584 (lambda (f)
585 (- f)))))
587 (decode-opcode #b001101 10
588 (lambda (opcode)
589 (byte-oriented opcode "rlcf" 'c-z-n
590 (lambda (f)
591 ;; the carry flag will be set automatically
592 (+ (arithmetic-shift f 1) (carry))))))
594 (decode-opcode #b010001 10
595 (lambda (opcode)
596 (byte-oriented opcode "rlncf" 'z-n
597 (lambda (f)
598 (+ (arithmetic-shift f 1) (arithmetic-shift f -7))))))
600 (decode-opcode #b001100 10
601 (lambda (opcode)
602 (byte-oriented opcode "rrcf" 'c-z-n
603 (lambda (f)
604 (let ((r (+ (arithmetic-shift f -1) (arithmetic-shift (carry) 7))))
605 ;; roll through carry (if the result is over #xff, carry will be set)
606 (if (= (bitwise-and f 1) 1) (+ r #x100) r))))))
608 (decode-opcode #b010000 10
609 (lambda (opcode)
610 (byte-oriented opcode "rrncf" 'z-n
611 (lambda (f)
612 (+ (arithmetic-shift f -1) (arithmetic-shift f 7))))))
614 (decode-opcode #b0110100 9
615 (lambda (opcode)
616 (byte-oriented-file opcode "setf" 'z
617 (lambda (f)
618 #xff))))
620 (decode-opcode #b010101 10
621 (lambda (opcode)
622 (byte-oriented opcode "subfwb" 'c-dc-z-ov-n
623 (lambda (f)
624 (- (get-wreg) f (carry))))))
626 (decode-opcode #b010111 10
627 (lambda (opcode)
628 (byte-oriented opcode "subwf" 'c-dc-z-ov-n
629 (lambda (f)
630 (- f (get-wreg))))))
632 (decode-opcode #b010110 10
633 (lambda (opcode)
634 (byte-oriented opcode "subwfb" 'c-dc-z-ov-n
635 (lambda (f)
636 (- f (get-wreg) (carry))))))
638 (decode-opcode #b001110 10
639 (lambda (opcode)
640 (byte-oriented opcode "swapf" 'none
641 (lambda (f)
642 (+ (arithmetic-shift f -4) (arithmetic-shift f 4))))))
644 (decode-opcode #b0110011 9
645 (lambda (opcode)
646 (byte-oriented-file opcode "tstfsz" 'none
647 (lambda (f)
648 (if (= f 0) (skip))))))
650 (decode-opcode #b000110 10
651 (lambda (opcode)
652 (byte-oriented opcode "xorwf" 'z-n
653 (lambda (f)
654 (bitwise-xor f (get-wreg))))))
656 ; Bit-oriented file register operations.
658 (decode-opcode #b1001 12
659 (lambda (opcode)
660 (bit-oriented opcode "bcf"
661 (lambda (f b)
662 (bitwise-and f (bitwise-not (arithmetic-shift 1 b)))))))
664 (decode-opcode #b1000 12
665 (lambda (opcode)
666 (bit-oriented opcode "bsf"
667 (lambda (f b)
668 (bitwise-ior f (arithmetic-shift 1 b))))))
670 (decode-opcode #b1011 12
671 (lambda (opcode)
672 (bit-oriented opcode "btfsc"
673 (lambda (f b)
674 (if (= 0 (bitwise-and f (arithmetic-shift 1 b))) (skip))
675 f))))
677 (decode-opcode #b1010 12
678 (lambda (opcode)
679 (bit-oriented opcode "btfss"
680 (lambda (f b)
681 (if (not (= 0 (bitwise-and f (arithmetic-shift 1 b)))) (skip))
682 f))))
684 (decode-opcode #b0111 12
685 (lambda (opcode)
686 (bit-oriented opcode "btg"
687 (lambda (f b)
688 (bitwise-xor f (arithmetic-shift 1 b))))))
690 ; Control operations.
692 (decode-opcode #b11100010 8
693 (lambda (opcode)
694 (short-relative-branch opcode "bc"
695 (lambda ()
696 (not (= 0 (carry)))))))
698 (decode-opcode #b11100110 8
699 (lambda (opcode)
700 (short-relative-branch opcode "bn" negative-flag?)))
702 (decode-opcode #b11100011 8
703 (lambda (opcode)
704 (short-relative-branch opcode "bnc"
705 (lambda ()
706 (= 0 (carry))))))
708 (decode-opcode #b11100111 8
709 (lambda (opcode)
710 (short-relative-branch opcode "bnn" negative-flag?)))
712 (decode-opcode #b11100101 8
713 (lambda (opcode)
714 (short-relative-branch opcode "bnov"
715 (lambda ()
716 (not (overflow-flag?))))))
718 (decode-opcode #b11100001 8
719 (lambda (opcode)
720 (short-relative-branch opcode "bnz"
721 (lambda ()
722 (not (zero-flag?))))))
724 (decode-opcode #b11100100 8
725 (lambda (opcode)
726 (short-relative-branch opcode "bov" overflow-flag?)))
728 (decode-opcode #b11010 11
729 (lambda (opcode)
730 (long-relative-branch opcode "bra" #f)))
732 (decode-opcode #b11100000 8
733 (lambda (opcode)
734 (short-relative-branch opcode "bz" zero-flag?)))
736 (decode-opcode #b1110110 9
737 (lambda (opcode)
738 (call-branch opcode "call")))
740 (decode-opcode #b11101111 8
741 (lambda (opcode)
742 (goto-branch opcode "goto")))
744 (decode-opcode #b11011 11
745 (lambda (opcode)
746 (long-relative-branch opcode "rcall" #t)))
748 (decode-opcode #b1111 12
749 (lambda (opcode)
750 (if trace-instr
751 (print (list (last-pc) " nop ")))))
753 (decode-opcode #b00000000 8
754 (lambda (opcode)
755 (cond ((= opcode #b0000000000000100)
756 (if trace-instr
757 (print (list (last-pc) " clrwdt ")))
758 (clrwdt opcode))
759 ((= opcode #b0000000000000111)
760 (if trace-instr
761 (print (list (last-pc) " daw ")))
762 (daw opcode))
763 ((= opcode #b0000000000000000)
764 (if trace-instr
765 (print (list (last-pc) " nop "))))
766 ((= opcode #b0000000000000110)
767 (if trace-instr
768 (print (list (last-pc) " pop ")))
769 (stack-pop))
770 ((= opcode #b0000000000000101)
771 (if trace-instr
772 (print (list (last-pc) " push ")))
773 (stack-push (get-pc)))
774 ((= opcode #b0000000011111111)
775 (if trace-instr
776 (print (list (last-pc) " reset ")))
777 (set-pc 0))
778 ((= opcode #b0000000000010000)
779 (if trace-instr
780 (print (list (last-pc) " retfie ")))
781 (get-program-mem)
782 (stack-pop))
783 ((= opcode #b0000000000010001)
784 (if trace-instr
785 (print (list (last-pc) " retfie FAST")))
786 (error "retfie fast not implemented")
787 (get-program-mem)
788 (stack-pop))
789 ((= opcode #b0000000000010010)
790 (if trace-instr
791 (print (list (last-pc) " return ")))
792 (get-program-mem)
793 (stack-pop))
794 ((= opcode #b0000000000010011)
795 (if trace-instr
796 (print (list (last-pc) " return FAST")))
797 (error "return fast not implemented")
798 (get-program-mem)
799 (stack-pop))
800 ((= opcode #b0000000000000011)
801 (if trace-instr
802 (print (list (last-pc) " sleep ")))
803 (set! pic18-exit #t))
804 ;; program memory operations
805 ((= opcode #b0000000000001000)
806 (program-memory-read "tblrd*" identity identity))
807 ((= opcode #b0000000000001001)
808 (program-memory-read "tblrd*+" identity (lambda (adr) (+ adr 1))))
809 ((= opcode #b0000000000001010)
810 (program-memory-read "tblrd*-" identity (lambda (adr) (- adr 1))))
811 ((= opcode #b0000000000001011)
812 (program-memory-read "tblrd+*"
813 (lambda (adr) (+ adr 1))
814 (lambda (adr) (+ adr 1))))
815 ((= opcode #b0000000000001100)
816 (program-memory-write "tblwt*" identity identity)) ;; TODO not implemented
817 ((= opcode #b0000000000001101)
818 (program-memory-write "tblwt*+" identity (lambda (adr) (+ adr 1))))
819 ((= opcode #b0000000000001110)
820 (program-memory-write "tblwt*-" identity (lambda (adr) (- adr 1))))
821 ((= opcode #b0000000000001111)
822 (program-memory-write "tblwt+*"
823 (lambda (adr) (+ adr 1))
824 (lambda (adr) (+ adr 1))))
825 (else
826 (if trace-instr
827 (print (list (last-pc) " ??? ")))
828 (error "???")))))
830 ; Literal operations.
832 (decode-opcode #b00001111 8
833 (lambda (opcode)
834 (literal-operation opcode "addlw" 'c-dc-z-ov-n
835 (lambda (k)
836 (+ k (get-wreg))))))
838 (decode-opcode #b00001011 8
839 (lambda (opcode)
840 (literal-operation opcode "andlw" 'z-n
841 (lambda (k)
842 (bitwise-and k (get-wreg))))))
844 (decode-opcode #b00001001 8
845 (lambda (opcode)
846 (literal-operation opcode "iorlw" 'z-n
847 (lambda (k)
848 (bitwise-ior k (get-wreg))))))
850 '
851 (define (lfsr f k)
852 (make-instruction
853 2
854 (lambda ()
855 (make-listing "lfsr" (file-text f) (lit-text k)))
856 (lambda ()
857 (asm-16 (bitmask "1110 1110 00ff kkkk" (file f) (quotient (lit k) 256)))
858 (asm-16 (bitmask "1111 0000 kkkk kkkk" (modulo (lit k) 256))))))
860 '
861 (define (movlb k)
862 (make-instruction
863 1
864 (lambda ()
865 (make-listing "movlb" (lit-text k)))
866 (lambda ()
867 (asm-16 (bitmask "0000 0001 0000 kkkk" (lit k))))))
869 (decode-opcode #b00001110 8
870 (lambda (opcode)
871 (literal-operation opcode "movlw" 'none
872 (lambda (k)
873 k))))
875 (decode-opcode #b00001101 8
876 (lambda (opcode)
877 (literal-operation opcode "mullw" 'none
878 (lambda (k)
879 (* k (get-wreg))))))
881 (decode-opcode #b00001100 8
882 (lambda (opcode)
883 (literal-operation opcode "retlw" 'none
884 (lambda (k)
885 (get-program-mem)
886 (stack-pop)
887 k))))
889 (decode-opcode #b00001000 8
890 (lambda (opcode)
891 (literal-operation opcode "sublw" 'c-dc-z-ov-n
892 (lambda (k)
893 (- k (get-wreg))))))
895 (decode-opcode #b00001010 8
896 (lambda (opcode)
897 (literal-operation opcode "xorlw" 'z-n
898 (lambda (k)
899 (bitwise-xor k (get-wreg))))))
902 ;------------------------------------------------------------------------------
904 (define (read-hex-file filename)
906 (define addr-width 32)
908 (define (syntax-error)
909 (error "*** Syntax error in HEX file"))
911 (let ((f
912 (with-exception-catcher
913 (lambda (exc)
914 #f)
915 (lambda ()
916 (open-input-file filename)))))
918 (define mem (make-vector 16 #f))
920 (define (mem-store! a b)
921 (let loop ((m mem)
922 (a a)
923 (x (- addr-width 4)))
924 (if (= x 0)
925 (vector-set! m a b)
926 (let ((i (arithmetic-shift a (- x))))
927 (let ((v (vector-ref m i)))
928 (loop (or v
929 (let ((v (make-vector 16 #f)))
930 (vector-set! m i v)
931 v))
932 (- a (arithmetic-shift i x))
933 (- x 4)))))))
935 (define (mem->list)
937 (define (f m a n tail)
939 (define (g i a n tail)
940 (if (>= i 0)
941 (g (- i 1) (- a n) n (f (vector-ref m i) a n tail))
942 tail))
944 (if m
945 (if (= n 1)
946 (cons (cons (- a 1) m) tail)
947 (g 15 a (quotient n 16) tail))
948 tail))
950 (f mem (expt 2 addr-width) (expt 2 addr-width) '()))
952 (define hi16
953 0)
955 (define (read-hex-nibble)
956 (let ((c (read-char f)))
957 (cond ((and (char>=? c #\0) (char<=? c #\9))
958 (- (char->integer c) (char->integer #\0)))
959 ((and (char>=? c #\A) (char<=? c #\F))
960 (+ 10 (- (char->integer c) (char->integer #\A))))
961 ((and (char>=? c #\a) (char<=? c #\f))
962 (+ 10 (- (char->integer c) (char->integer #\a))))
963 (else
964 (syntax-error)))))
966 (define (read-hex-byte)
967 (let* ((a (read-hex-nibble))
968 (b (read-hex-nibble)))
969 (+ b (* a 16))))
971 (if f
972 (begin
973 (let loop1 ()
974 (let ((c (read-char f)))
975 (cond ((not (char? c)))
976 ((or (char=? c #\linefeed)
977 (char=? c #\return))
978 (loop1))
979 ((not (char=? c #\:))
980 (syntax-error))
981 (else
982 (let* ((len (read-hex-byte))
983 (a1 (read-hex-byte))
984 (a2 (read-hex-byte))
985 (type (read-hex-byte)))
986 (let* ((adr (+ a2 (* 256 a1)))
987 (sum (+ len a1 a2 type)))
988 (cond ((= type 0)
989 (let loop2 ((i 0))
990 (if (< i len)
991 (let ((a (+ adr (* hi16 65536)))
992 (b (read-hex-byte)))
993 (mem-store! a b)
994 (set! adr (modulo (+ adr 1) 65536))
995 (set! sum (+ sum b))
996 (loop2 (+ i 1))))))
997 ((= type 1)
998 (if (not (= len 0))
999 (syntax-error)))
1000 ((= type 4)
1001 (if (not (= len 2))
1002 (syntax-error))
1003 (let* ((a1 (read-hex-byte))
1004 (a2 (read-hex-byte)))
1005 (set! sum (+ sum a1 a2))
1006 (set! hi16 (+ a2 (* 256 a1)))))
1007 (else
1008 (syntax-error)))
1009 (let ((check (read-hex-byte)))
1010 (if (not (= (modulo (- sum) 256) check))
1011 (syntax-error)))
1012 (let ((c (read-char f)))
1013 (if (or (not (or (char=? c #\linefeed)
1014 (char=? c #\return)))
1015 (not (= type 1)))
1016 (loop1)))))))))
1018 (close-input-port f)
1020 (mem->list))
1021 (begin
1022 (error "*** Could not open the HEX file")
1023 #f))))
1025 ;------------------------------------------------------------------------------
1027 (define (execute-hex-files . filenames)
1028 (let ((programs (map read-hex-file filenames)))
1029 (pic18-sim-setup)
1030 (for-each (lambda (prog)
1031 (for-each (lambda (x) (set-rom (car x) (cdr x)))
1032 prog))
1033 programs)
1034 (pic18-execute)
1035 (pic18-sim-cleanup)))
1037 (define (show-profiling-data) ;; TODO temporary solution until we have the true profile working
1038 (with-input-from-file asm-filename
1039 (lambda ()
1040 (let loop ((line (read-line)))
1041 (if (not (eq? line #!eof))
1042 (begin (if (not (eq? (string-ref line 0) #\tab)) ; not a label
1043 (let ((adr (string->number (car (split-string line
1044 #\space))
1045 16)))
1046 (print (list (vector-ref instrs-counts adr)
1047 " "))))
1048 (print (list line "\n"))
1049 (loop (read-line))))))))
1050 (define (dump-profiling-data file)
1051 (with-output-to-file file show-profiling-data))
1053 ;; debugging procedures
1054 (define (add-break-point adr) (set! break-points (cons adr break-points)))
1055 (define (continue) (set! trace-instr #f) (set! single-stepping-mode? #f)) ;; TODO + the equivalent of ,c
1057 (define (fixed? o) (< o 260))
1058 (define (in-rom? o) (and (>= o 260) (< o 512)))
1059 (define (in-ram? o) (and (>= o 512) (< o 4096)))
1061 (define (obj->ram o field)
1062 (get-ram (+ 512 (arithmetic-shift (- o 512) 2) field)))
1063 (define (ram-get-car o) (get-car obj->ram o))
1064 (define (ram-get-cdr o) (get-cdr obj->ram o))
1065 (define (ram-get-entry o) (get-entry obj->ram o))
1067 (define (obj->rom o field)
1068 (get-rom (+ #x8000 (arithmetic-shift (- o 260) 2) 4 field)))
1069 (define (rom-get-car o) (get-car obj->rom o))
1070 (define (rom-get-cdr o) (get-cdr obj->rom o))
1071 (define (rom-get-entry o) (get-entry obj->rom o))
1073 (define (picobit-object o)
1075 (define (get-car f o)
1076 (bitwise-ior (arithmetic-shift (bitwise-and (f o 0) #x1f) 8)
1077 (f o 1)))
1078 (define (get-cdr f o)
1079 (bitwise-ior (arithmetic-shift (bitwise-and (f o 2) #x1f) 8)
1080 (f o 3)))
1081 (define (get-entry f o)
1082 (bitwise-ior (arithmetic-shift (bitwise-and (f o 0) #x1f) 11)
1083 (arithmetic-shift (f o 1) 3)
1084 (arithmetic-shift (f o 2) -5)))
1086 (define (show-pair f ptr)
1087 (let* ((obj (get-car f ptr))
1088 (next (get-cdr f ptr))
1089 (f (if (in-rom? next) obj->rom obj->ram)))
1090 (show-obj obj)
1091 (cond ((= next 2)) ; '()
1092 ((and (or (in-rom? next) (in-ram? next))
1093 (= (bitwise-and (f next 0) #x80) #x80) ; composite
1094 (= (bitwise-and (f next 2) #xe0) 0)) ; pair
1095 (display " ")
1096 (show-pair f next))
1097 (else (display " . ")
1098 (show-obj next)))))
1099 (define (integer-hi o)
1100 (cond ((in-ram? o) (ram-get-car o))
1101 ((in-rom? o) (rom-get-car o))
1102 ((< o 4) -1) ; negative fixnum
1103 (else 0))) ; non-negative fixnum
1104 (define (integer-lo o)
1105 (cond ((or (in-ram? o) (in-rom? o))
1106 (let ((f (if (in-rom? o) obj->rom obj->ram)))
1107 (+ (arithmetic-shift (f o 2) 8) (f o 3))))
1108 (else
1109 (- o 4))))
1110 (define (print-bignum o)
1111 (let loop ((o o) (n 0) (s 0))
1112 (let ((lo (integer-lo o))
1113 (hi (integer-hi o)))
1114 (cond ((= hi 0) (display (+ lo n)))
1115 ((= hi -1) (display (- (+ lo n 1) (expt 2 s))))
1116 (else (loop hi
1117 (+ n lo)
1118 (+ s 16)))))))
1120 (define (show-obj o)
1121 (cond ((= o 0) (display #f))
1122 ((= o 1) (display #t))
1123 ((= o 2) (display '()))
1124 ((< o (+ 3 255 1 1)) ; fixnum
1125 (display (- o 4)))
1126 ((or (in-rom? o) (in-ram? o))
1127 (let* ((f (if (in-rom? o) obj->rom obj->ram))
1128 (obj (bitwise-ior (arithmetic-shift (f o 0) 24)
1129 (arithmetic-shift (f o 1) 16)
1130 (arithmetic-shift (f o 2) 8)
1131 (f o 3))))
1132 (cond ((= (bitwise-and obj #xc0000000) 0)
1133 (print-bignum o))
1134 ((= (bitwise-and obj #x80000000) #x80000000) ; composite
1135 (cond ((= (bitwise-and obj #x0000e000) 0) ; pair
1136 (display "(")
1137 (show-pair f o)
1138 (display ")"))
1139 ((= (bitwise-and obj #x0000e000) #x2000)
1140 (display "#<symbol>"))
1141 ((= (bitwise-and obj #x0000e000) #x4000)
1142 (display "#<string>"))
1143 ((= (bitwise-and obj #x0000e000) #x6000)
1144 (display "#<vector")
1145 (display (string-append
1146 "@" (number->string (get-cdr f o)) " "))
1147 (if (in-rom? o)
1148 (let loop ((n (- (rom-get-car o) 1))
1149 (adr (rom-get-cdr o)))
1150 (show-obj (rom-get-car adr))
1151 (if (not (= n 0))
1152 (begin (display " ")
1153 (loop (- n 1)
1154 (rom-get-cdr adr)))))
1155 (let loop ((n (- (get-car f o) 1))
1156 (adr (+ 512
1157 (arithmetic-shift
1158 (- (get-cdr f o) 512) 2))))
1159 (display (number->string (get-ram adr)))
1160 (if (not (= n 0))
1161 (begin (display " ")
1162 (loop (- n 1)
1163 (+ adr 1))))))
1164 (display ">"))
1165 ((= (bitwise-and obj #x0000e000) #x8000)
1166 (display "#<cont: ")
1167 (show-obj (get-cdr f o))
1168 (display " ")
1169 (show-obj (get-car f o))
1170 (display ">"))
1171 (else (display "unknown?"))))
1172 (else
1173 (display (string-append "{0x"
1174 (number->string (get-entry f o)
1175 16)
1176 " "))
1177 (show-obj (get-cdr f o))
1178 (display "}")))))
1179 (else (display "invalid"))))
1181 (show-obj o)
1182 (display "\n"))
1184 (define picobit-trace? #t)
1185 (define (picobit-pc)
1186 (number->string (+ (* 256 (get-ram (table-ref reverse-register-table
1187 "pc$1")))
1188 (get-ram (table-ref reverse-register-table
1189 "pc$0")))
1190 16))
1191 (define (picobit-var var)
1192 (+ (* 256 (get-ram (table-ref reverse-register-table
1193 (string-append var "$1"))))
1194 (get-ram (table-ref reverse-register-table (string-append var "$0")))))
1195 (define (picobit-stack) (picobit-object (picobit-var "env")))
1196 (define (picobit-continuation) (picobit-object (picobit-var "cont")))
1197 (define (picobit-instruction)
1198 (let* ((opcode (get-ram (table-ref reverse-register-table
1199 "bytecode$0")))
1200 (bytecode-hi4 (arithmetic-shift (bitwise-and opcode #xf0) -4))
1201 (bytecode-lo4 (bitwise-and opcode #x0f)))
1202 (pp (number->string opcode 16))
1203 (pp (case bytecode-hi4
1204 ((0) (list 'push-constant bytecode-lo4)) ;; TODO use picobit-object
1205 ((1) (list 'push-constant (+ bytecode-lo4 16)))
1206 ((2) (list 'push-stack bytecode-lo4))
1207 ((3) (list 'push-stack (+ bytecode-lo4 16)))
1208 ((4) (list 'push-global bytecode-lo4))
1209 ((5) (list 'set-global bytecode-lo4))
1210 ((6) (list 'call bytecode-lo4))
1211 ((7) (list 'jump bytecode-lo4))
1212 ((8) (case bytecode-lo4
1213 ((0) 'call-toplevel) ;; TODO these require the further bytecodes to display completely
1214 ((1) 'jump-toplevel)
1215 ((2) 'goto)
1216 ((3) 'goto-if-false)
1217 ((4) 'closure)
1218 ((14) 'push-global)
1219 ((15) 'set-global)))
1220 ((9) 'push-constant-long)
1221 ((12) (case bytecode-lo4
1222 ((0) 'prim-number?)
1223 ((1) 'prim-+)
1224 ((2) 'prim--)
1225 ((3) 'prim-*)
1226 ((4) 'prim-/)
1227 ((5) 'prim-remainder)
1228 ((6) 'prim-neg)
1229 ((7) 'prim-=)
1230 ((8) 'prim-<)
1231 ((9) 'prim-<=)
1232 ((10) 'prim->)
1233 ((11) 'prim->=)
1234 ((12) 'prim-pair?)
1235 ((13) 'prim-cons)
1236 ((14) 'prim-car)
1237 ((15) 'prim-cdr)))
1238 ((13) (case bytecode-lo4
1239 ((0) 'prim-set-car!)
1240 ((1) 'prim-set-cdr!)
1241 ((2) 'prim-null?)
1242 ((3) 'prim-eq?)
1243 ((4) 'prim-not)
1244 ((5) 'prim-get-cont)
1245 ((6) 'prim-graft-to-cont)
1246 ((7) 'prim-return-to-cont)
1247 ((8) 'prim-halt)
1248 ((9) 'prim-symbol?)
1249 ((10) 'prim-string?)
1250 ((11) 'prim-string->list)
1251 ((12) 'prim-list->string)
1252 ((13) 'prim-make-u8vector)
1253 ((14) 'prim-u8vector-ref)
1254 ((15) 'prim-u8vector-set)))
1255 ((14) (case bytecode-lo4
1256 ((0) 'prim-print)
1257 ((1) 'prim-clock)
1258 ((2) 'prim-motor)
1259 ((3) 'prim-led)
1260 ((4) 'prim-led2color)
1261 ((5) 'prim-getchar-wait)
1262 ((6) 'prim-putchar)
1263 ((7) 'prim-beep)
1264 ((8) 'prim-adc)
1265 ((9) 'prim-u8vector?)
1266 ((10) 'prim-sernum)
1267 ((11) 'prim-u8vector-length)
1268 ((12) 'prim-u8vector-copy!)
1269 ((13) 'shift)
1270 ((14) 'pop)
1271 ((15) 'return)))
1272 ((15) (case bytecode-lo4
1273 ((0) 'prim-boolean?)
1274 ((1) 'prim-network-init)
1275 ((2) 'prim-network-cleanup)
1276 ((3) 'prim-receive-packet-to-u8vector)
1277 ((4) 'prim-send-packet-to-u8vector)
1278 ((5) 'prim-ior)
1279 ((6) 'prim-xor)))))))