| blob | 465845903a79e46287a271d90ba724608764994a |
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)
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 STATUS)
69 (set! pic18-carry-flag (bitwise-and byte 1))
70 (set! pic18-deccarry-flag (arithmetic-shift (bitwise-and byte 2) -1))
71 (set! pic18-zero-flag (arithmetic-shift (bitwise-and byte 4) -2))
72 (set! pic18-overflow-flag (arithmetic-shift (bitwise-and byte 8) -3))
73 (set! pic18-negative-flag (arithmetic-shift (bitwise-and byte 16) -4)))
74 ((assq adr fsr-alist)
75 => (lambda (x)
76 (set-ram (bitwise-ior ;; TODO factor common code with get-ram ?
77 (arithmetic-shift (bitwise-and (u8vector-ref pic18-ram
78 (cadr x))
79 #xf)
80 8)
81 (u8vector-ref pic18-ram
82 (cddr x)))
83 byte)))
84 ;; TODO all other special array registers
85 (else
86 (u8vector-set! pic18-ram adr byte))))
88 (define (get-rom adr)
89 (u8vector-ref pic18-rom adr))
91 (define (set-rom adr byte)
92 (u8vector-set! pic18-rom adr byte))
94 (define (get-stack adr)
95 (vector-ref pic18-stack adr))
97 (define (set-stack adr pc)
98 (vector-set! pic18-stack adr pc))
100 (define (get-pc)
101 pic18-pc)
103 (define (set-pc pc)
104 (set! pic18-pc pc))
106 (define (get-sp)
107 (bitwise-and (get-ram STKPTR) #x1f))
109 (define (set-sp sp)
110 (set-ram STKPTR
111 (bitwise-ior sp
112 (bitwise-and (get-ram STKPTR) #xe0))))
114 (define (get-tos)
115 (vector-ref pic18-stack (- (get-sp) 1)))
117 (define (set-tos pc)
118 (vector-set! pic18-stack (- (get-sp) 1) pc))
120 (define (stack-push pc)
121 (set-sp (+ (get-sp) 1))
122 (set-tos pc))
124 (define (stack-pop)
125 (set-pc (get-tos))
126 (set-sp (- (get-sp) 1)))
128 (define (get-bsr)
129 (bitwise-and (get-ram BSR) #x0f))
131 (define (get-wreg)
132 (get-ram WREG))
134 (define (set-wreg byte)
135 (set-ram WREG byte))
137 (define (zero-flag?)
138 (not (= 0 pic18-zero-flag)))
140 (define (set-zero-flag flag)
141 (set! pic18-zero-flag flag))
143 (define (negative-flag?)
144 (not (= 0 pic18-negative-flag)))
146 (define (set-negative-flag flag)
147 (set! pic18-negative-flag flag))
149 (define (carry-flag?)
150 (not (= 0 pic18-carry-flag)))
152 (define (set-carry-flag flag)
153 (set! pic18-carry-flag flag))
155 (define (deccarry-flag?)
156 (not (= 0 pic18-deccarry-flag)))
158 (define (set-deccarry-flag flag)
159 (set! pic18-deccarry-flag flag))
161 (define (overflow-flag?)
162 (not (= 0 pic18-overflow-flag)))
164 (define (set-overflow-flag flag)
165 (set! pic18-overflow-flag flag))
167 (define (pic18-sim-setup)
168 (set! pic18-ram (make-u8vector #x1000 0))
169 (set! pic18-rom (make-u8vector #x10000 0))
170 (set! pic18-stack (make-vector #x1f 0))
171 (set! instrs-counts (make-vector #x10000 0))
172 (set-pc 0)
173 (set-wreg 0)
174 (set! pic18-carry-flag 0)
175 (set! pic18-deccarry-flag 0)
176 (set! pic18-zero-flag 0)
177 (set! pic18-overflow-flag 0)
178 (set! pic18-negative-flag 0))
180 (define (pic18-sim-cleanup)
181 (set! pic18-ram #f)
182 (set! pic18-rom #f)
183 (set! pic18-stack #f))
185 ;------------------------------------------------------------------------------
187 (define (last-pc)
188 (let ((pc (- (get-pc) 2)))
189 (list (get-sp) " " (- pic18-cycles 1) " "
190 (substring (number->string (+ #x1000000 pc) 16) 1 7)
191 " ")))
193 (define (illegal-opcode opcode)
194 (if trace-instr
195 (print (list (last-pc) " *illegal*")))
196 (error "illegal opcode" opcode))
198 (define decode-vector
199 (make-vector 256 illegal-opcode))
201 (define (decode-opcode opcode-bits shift action)
202 (if (< shift 8)
203 (error "shift=" shift))
204 (let ((n (arithmetic-shift 1 (- shift 8)))
205 (base (arithmetic-shift opcode-bits (- shift 8))))
206 (let loop ((i 0))
207 (if (< i n)
208 (begin
209 (vector-set! decode-vector (+ base i) action)
210 (loop (+ i 1)))))))
212 (define (byte-oriented opcode mnemonic flags-changed operation)
213 (byte-oriented-aux opcode mnemonic flags-changed operation 'wreg))
214 (define (byte-oriented-file opcode mnemonic flags-changed operation)
215 (byte-oriented-aux opcode mnemonic flags-changed operation 'file))
216 (define (byte-oriented-wide opcode mnemonic flags-changed operation dest)
217 ;; for use with instructions that have results more than a byte wide, such
218 ;; as multiplication. the result goes at the given addresses
219 (byte-oriented-aux opcode mnemonic flags-changed operation dest)) ;; TODO do the same for literals
221 (define (byte-oriented-aux opcode mnemonic flags-changed operation dest)
222 (let* ((f (bitwise-and opcode #xff))
223 (adr (if (= 0 (bitwise-and opcode #x100))
224 ;; the upper 160 addresses of the first bank are the special
225 ;; registers #xF60 to #xFFF
226 (if (= 0 (bitwise-and f #x80)) f (+ f #xf00))
227 (+ f (arithmetic-shift (get-bsr) 8)))))
228 (if trace-instr
229 (print (list (last-pc) " " mnemonic " "
230 (let ((x (assv adr file-reg-names)))
231 (if x
232 (cdr x)
233 (let ((x (table-ref register-table f #f)))
234 (if #f ;x ;; TODO unreadable with picobit
235 (apply string-append-with-separator (cons "/" x))
236 (list "0x" (number->string adr 16))))))
237 (if (or (eq? dest 'wreg)
238 (= 0 (bitwise-and opcode #x200)))
239 ", w"
240 "")
241 "")))
242 (let* ((result (operation (get-ram adr)))
243 (result-8bit (bitwise-and result #xff)))
244 (cond ((list? dest)
245 ;; result is more than a byte wide (i.e. multiplication)
246 ;; put it in the right destinations (dest is a list of addresses)
247 (let loop ((dest dest) (result result))
248 (if (not (null? dest))
249 ;; the head of the list is the lsb
250 (begin (set-ram (car dest) (bitwise-and result #xff))
251 (loop (cdr dest) (arithmetic-shift result -8))))))
252 ((or (eq? dest 'file) (not (= 0 (bitwise-and opcode #x200))))
253 ;; the result goes in memory (file)
254 (set-ram adr result-8bit))
255 ((eq? dest 'wreg)
256 ;; result goes in wreg
257 (set-wreg result-8bit)))
258 (if (not (eq? flags-changed 'none))
259 (begin
260 (set-zero-flag (if (= 0 result-8bit) 1 0))
261 (if (not (eq? flags-changed 'z))
262 (begin
263 (set-negative-flag (if (> result-8bit #x7f) 1 0))
264 (if (not (eq? flags-changed 'z-n))
265 (begin
266 (set-carry-flag (if (or (> result #xff)
267 (< result 0))
268 1 0))
269 (if (not (eq? flags-changed 'c-z-n))
270 (begin
271 (set-deccarry-flag 0);;;;;;;;;;;;;;
272 (set-overflow-flag 0))))))))))));;;;;;;;;;;;;;
274 (define (bit-oriented opcode mnemonic operation)
275 (let* ((f (bitwise-and opcode #xff))
276 (adr (if (= 0 (bitwise-and opcode #x100))
277 (if (= 0 (bitwise-and f #x80)) f (+ f #xf00))
278 (+ f (arithmetic-shift (get-bsr) 8))))
279 (b (bitwise-and (arithmetic-shift opcode -9) 7)))
280 (if trace-instr
281 (print (list (last-pc) " " mnemonic " "
282 (let ((x (assv adr file-reg-names)))
283 (if x (cdr x) (list "0x" (number->string adr 16))))
284 ", "
285 (if (= adr STATUS)
286 (cdr (assv b '((0 . C)
287 (1 . DC)
288 (2 . Z)
289 (3 . OV)
290 (4 . N)
291 (5 . 5)
292 (6 . 6)
293 (7 . 7))))
294 b)
295 "")))
296 (let* ((result (operation (get-ram adr) b))
297 (result-8bit (bitwise-and result #xff)))
298 (set-ram adr result-8bit))))
300 (define (short-relative-branch opcode mnemonic branch)
301 (let* ((n (bitwise-and opcode #xff))
302 (adr (+ (get-pc) (* 2 (if (> n #x7f) (- n #x100) n)))))
303 (if trace-instr
304 (print (list (last-pc) " " mnemonic " "
305 (symbol->string (table-ref symbol-table adr)))))
306 (if (branch)
307 (begin
308 (get-program-mem)
309 (set-pc adr)))))
311 (define (long-relative-branch opcode mnemonic call?)
312 (let* ((n (bitwise-and opcode #x7ff))
313 (adr (+ (get-pc) (* 2 (if (> n #x3ff) (- n #x800) n)))))
314 (if trace-instr
315 (print (list (last-pc) " " mnemonic " "
316 (symbol->string (table-ref symbol-table adr)))))
317 (if call?
318 (stack-push (get-pc)))
319 (get-program-mem)
320 (set-pc adr)))
322 (define (call-branch opcode mnemonic)
323 (let ((adr (* 2 (+ (bitwise-and opcode #xff)
324 (arithmetic-shift (bitwise-and (get-program-mem) #xfff) 8)))))
325 (if trace-instr
326 (print (list (last-pc) " " mnemonic " "
327 (symbol->string (table-ref symbol-table adr))
328 (if (= 0 (bitwise-and opcode #x100))
329 ""
330 ", FAST"))))
331 (stack-push (get-pc))
332 (if (not (= 0 (bitwise-and opcode #x100)))
333 (error "call fast not implemented"))
334 (set-pc adr)))
336 (define (goto-branch opcode mnemonic)
337 (let ((adr (* 2 (+ (bitwise-and opcode #xff)
338 (arithmetic-shift (bitwise-and (get-program-mem) #xfff) 8)))))
339 (if trace-instr
340 (print (list (last-pc) " " mnemonic " "
341 (symbol->string (table-ref symbol-table adr)))))
342 (set-pc adr)))
344 (define (literal-operation opcode mnemonic flags-changed operation)
345 (let ((k (bitwise-and opcode #xff)))
346 (if trace-instr
347 (print (list (last-pc) " " mnemonic " "
348 (if (< k 10) k (list "0x" (number->string k 16))))))
349 (let* ((result (operation k))
350 (result-8bit (bitwise-and result #xff)))
351 (set-wreg result-8bit)
352 (if (not (eq? flags-changed 'none))
353 (begin
354 (set-zero-flag (if (= 0 result-8bit) 1 0))
355 (if (not (eq? flags-changed 'z))
356 (begin
357 (set-negative-flag (if (> result-8bit #x7f) 1 0))
358 (if (not (eq? flags-changed 'z-n))
359 (begin
360 (set-carry-flag (if (> result #xff) 1 0))
361 (if (not (eq? flags-changed 'c-z-n))
362 (begin
363 (set-deccarry-flag 0);;;;;;;;;;;;;;
364 (set-overflow-flag 0))))))))))));;;;;;;;;;;;;;
366 (define (program-memory-read mnemonic read-adr-fun set-adr-fun)
367 (if trace-instr
368 (print (list (last-pc) " " mnemonic " ")))
369 (let ((adr (bitwise-ior (arithmetic-shift (get-ram TBLPTRU) 16)
370 (arithmetic-shift (get-ram TBLPTRH) 8)
371 (get-ram TBLPTRL))))
372 (set-ram TABLAT (get-rom (bitwise-and (read-adr-fun adr)
373 ;; rom addresses are 21 bits wide
374 #x1fffff)))
375 (let ((new-adr (bitwise-and (set-adr-fun adr) #x1fffff)))
376 (set-ram TBLPTRU (arithmetic-shift new-adr -16))
377 (set-ram TBLPTRH (bitwise-and (arithmetic-shift new-adr -8) #xff))
378 (set-ram TBLPTRL (bitwise-and new-adr #xff)))))
380 (define (get-program-mem)
381 (set! pic18-cycles (+ pic18-cycles 1))
382 (let* ((pc (get-pc))
383 (lsb (get-rom pc))
384 (msb (get-rom (+ pc 1))))
385 (set-pc (+ (get-pc) 2))
386 (+ (arithmetic-shift msb 8) lsb)))
388 (define (skip)
389 (get-program-mem))
391 (define (hex n)
392 (substring (number->string (+ #x100 n) 16) 1 3))
394 (define (dump-mem)
396 (print " ")
397 (let loop ((i 0))
398 (if (< i 10)
399 (begin
400 (print (list (hex (u8vector-ref pic18-ram i)) " "))
401 (loop (+ i 1)))))
402 (print (list " WREG=" (hex (get-wreg)) "\n")))
404 (define single-stepping-mode? #f)
405 (define (pic18-execute)
406 (set! pic18-exit #f)
407 (set! pic18-cycles 0)
408 (if trace-instr
409 (print " "))
410 (let loop ()
411 (if trace-instr
412 (dump-mem))
413 (if pic18-exit
414 (begin
415 (print (list "WREG = d'" (get-wreg) "'\n")))
416 (let ((opcode (get-program-mem))
417 (pc (- (get-pc) 2)))
418 (vector-set! instrs-counts pc (+ (vector-ref instrs-counts pc) 1))
419 (if (member pc break-points)
420 (begin (pp (list "break point at: " (number->string pc 16)))
421 (set! trace-instr #t)
422 (set! single-stepping-mode? #t)))
423 (if single-stepping-mode? (step))
424 (let ((proc (vector-ref decode-vector (arithmetic-shift opcode -8))))
425 (proc opcode)
426 (loop))))))
428 (define trace-instr #t)
430 (define (carry)
431 (if (> pic18-carry-flag 0)
432 (begin (set! pic18-carry-flag #f)
433 1)
434 0))
436 ;------------------------------------------------------------------------------
438 ; Byte-oriented file register operations.
440 (decode-opcode #b001001 10
441 (lambda (opcode)
442 (byte-oriented opcode "addwf" 'c-dc-z-ov-n
443 (lambda (f)
444 (+ f (get-wreg))))))
446 (decode-opcode #b001000 10
447 (lambda (opcode)
448 (byte-oriented opcode "addwfc" 'c-dc-z-ov-n
449 (lambda (f)
450 (+ f (get-wreg) (carry))))))
452 (decode-opcode #b000101 10
453 (lambda (opcode)
454 (byte-oriented opcode "andwf" 'z-n
455 (lambda (f)
456 (bitwise-and f (get-wreg))))))
458 (decode-opcode #b0110101 9
459 (lambda (opcode)
460 (byte-oriented-file opcode "clrf" 'z
461 (lambda (f)
462 0))))
464 (decode-opcode #b000111 10
465 (lambda (opcode)
466 (byte-oriented opcode "comf" 'z-n
467 (lambda (f)
468 (bitwise-not f)))))
470 (decode-opcode #b0110001 9
471 (lambda (opcode)
472 (byte-oriented-file opcode "cpfseq" 'none
473 (lambda (f)
474 (if (= f (get-wreg)) (skip))
475 f))))
477 (decode-opcode #b0110010 9
478 (lambda (opcode)
479 (byte-oriented-file opcode "cpfsgt" 'none
480 (lambda (f)
481 (if (> f (get-wreg)) (skip))
482 f))))
484 (decode-opcode #b0110000 9
485 (lambda (opcode)
486 (byte-oriented-file opcode "cpfslt" 'none
487 (lambda (f)
488 (if (< f (get-wreg)) (skip))
489 f))))
491 (decode-opcode #b000001 10
492 (lambda (opcode)
493 (byte-oriented opcode "decf" 'c-dc-z-ov-n
494 (lambda (f)
495 (- f 1)))))
497 (decode-opcode #b001011 10
498 (lambda (opcode)
499 (byte-oriented opcode "decfsz" 'none
500 (lambda (f)
501 (if (= f 1) (skip))
502 (- f 1)))))
504 (decode-opcode #b010011 10
505 (lambda (opcode)
506 (byte-oriented opcode "dcfsnz" 'none
507 (lambda (f)
508 (if (not (= f 1)) (skip))
509 (- f 1)))))
511 (decode-opcode #b001010 10
512 (lambda (opcode)
513 (byte-oriented opcode "incf" 'c-dc-z-ov-n
514 (lambda (f)
515 (+ f 1)))))
517 (decode-opcode #b001111 10
518 (lambda (opcode)
519 (byte-oriented opcode "incfsz" 'none
520 (lambda (f)
521 (if (= f #xff) (skip))
522 (+ f 1)))))
524 (decode-opcode #b010010 10
525 (lambda (opcode)
526 (byte-oriented opcode "infsnz" 'none
527 (lambda (f)
528 (if (not (= f #xff)) (skip))
529 (+ f 1)))))
531 (decode-opcode #b000100 10
532 (lambda (opcode)
533 (byte-oriented opcode "iorwf" 'z-n
534 (lambda (f)
535 (bitwise-ior f (get-wreg))))))
537 (decode-opcode #b010100 10
538 (lambda (opcode)
539 (byte-oriented opcode "movf" 'z-n
540 (lambda (f)
541 f))))
543 (decode-opcode #b1100 12
544 (lambda (opcode)
545 (let* ((src (bitwise-and opcode #xfff))
546 ;; the destination is in the second 16-bit part, need to fetch
547 (dst (bitwise-and (get-program-mem) #xfff)))
548 (if trace-instr
549 (print (list (last-pc) " movff "
550 (let ((x (assv src file-reg-names)))
551 (if x (cdr x) (list "0x" (number->string src 16))))
552 ", "
553 (let ((x (assv dst file-reg-names)))
554 (if x (cdr x) (list "0x" (number->string dst 16)))) ;; TODO printing 2 args ruins the formatting
555 "")))
556 (set-ram dst (get-ram src)))))
558 (decode-opcode #b0110111 9
559 (lambda (opcode)
560 (byte-oriented-file opcode "movwf" 'none
561 (lambda (f)
562 (get-wreg)))))
564 (decode-opcode #b0000001 9
565 (lambda (opcode)
566 (byte-oriented-wide opcode "mulwf" 'none
567 (lambda (f)
568 (* f (get-wreg)))
569 (list PRODL PRODH))))
571 (decode-opcode #b0110110 9
572 (lambda (opcode)
573 (byte-oriented-file opcode "negf" 'c-dc-z-ov-n
574 (lambda (f)
575 (- f)))))
577 (decode-opcode #b001101 10
578 (lambda (opcode)
579 (byte-oriented opcode "rlcf" 'c-z-n
580 (lambda (f)
581 ;; the carry flag will be set automatically
582 (+ (arithmetic-shift f 1) (carry))))))
584 (decode-opcode #b010001 10
585 (lambda (opcode)
586 (byte-oriented opcode "rlncf" 'z-n
587 (lambda (f)
588 (+ (arithmetic-shift f 1) (arithmetic-shift f -7))))))
590 (decode-opcode #b001100 10
591 (lambda (opcode)
592 (byte-oriented opcode "rrcf" 'c-z-n
593 (lambda (f)
594 (let ((r (+ (arithmetic-shift f -1) (arithmetic-shift (carry) 7))))
595 ;; roll through carry (if the result is over #xff, carry will be set)
596 (if (= (bitwise-and f 1) 1) (+ r #x100) r))))))
598 (decode-opcode #b010000 10
599 (lambda (opcode)
600 (byte-oriented opcode "rrncf" 'z-n
601 (lambda (f)
602 (+ (arithmetic-shift f -1) (arithmetic-shift f 7))))))
604 (decode-opcode #b0110100 9
605 (lambda (opcode)
606 (byte-oriented-file opcode "setf" 'z
607 (lambda (f)
608 #xff))))
610 (decode-opcode #b010101 10
611 (lambda (opcode)
612 (byte-oriented opcode "subfwb" 'c-dc-z-ov-n
613 (lambda (f)
614 (- (get-wreg) f (carry))))))
616 (decode-opcode #b010111 10
617 (lambda (opcode)
618 (byte-oriented opcode "subwf" 'c-dc-z-ov-n
619 (lambda (f)
620 (- f (get-wreg))))))
622 (decode-opcode #b010110 10
623 (lambda (opcode)
624 (byte-oriented opcode "subwfb" 'c-dc-z-ov-n
625 (lambda (f)
626 (- f (get-wreg) (carry))))))
628 (decode-opcode #b001110 10
629 (lambda (opcode)
630 (byte-oriented opcode "swapf" 'none
631 (lambda (f)
632 (+ (arithmetic-shift f -4) (arithmetic-shift f 4))))))
634 (decode-opcode #b0110011 9
635 (lambda (opcode)
636 (byte-oriented-file opcode "tstfsz" 'none
637 (lambda (f)
638 (if (= f 0) (skip))))))
640 (decode-opcode #b000110 10
641 (lambda (opcode)
642 (byte-oriented opcode "xorwf" 'z-n
643 (lambda (f)
644 (bitwise-xor f (get-wreg))))))
646 ; Bit-oriented file register operations.
648 (decode-opcode #b1001 12
649 (lambda (opcode)
650 (bit-oriented opcode "bcf"
651 (lambda (f b)
652 (bitwise-and f (bitwise-not (arithmetic-shift 1 b)))))))
654 (decode-opcode #b1000 12
655 (lambda (opcode)
656 (bit-oriented opcode "bsf"
657 (lambda (f b)
658 (bitwise-ior f (arithmetic-shift 1 b))))))
660 (decode-opcode #b1011 12
661 (lambda (opcode)
662 (bit-oriented opcode "btfsc"
663 (lambda (f b)
664 (if (= 0 (bitwise-and f (arithmetic-shift 1 b))) (skip))
665 f))))
667 (decode-opcode #b1010 12
668 (lambda (opcode)
669 (bit-oriented opcode "btfss"
670 (lambda (f b)
671 (if (not (= 0 (bitwise-and f (arithmetic-shift 1 b)))) (skip))
672 f))))
674 (decode-opcode #b0111 12
675 (lambda (opcode)
676 (bit-oriented opcode "btg"
677 (lambda (f b)
678 (bitwise-xor f (arithmetic-shift 1 b))))))
680 ; Control operations.
682 (decode-opcode #b11100010 8
683 (lambda (opcode)
684 (short-relative-branch opcode "bc"
685 (lambda ()
686 (not (= 0 (carry)))))))
688 (decode-opcode #b11100110 8
689 (lambda (opcode)
690 (short-relative-branch opcode "bn" negative-flag?)))
692 (decode-opcode #b11100011 8
693 (lambda (opcode)
694 (short-relative-branch opcode "bnc"
695 (lambda ()
696 (= 0 (carry))))))
698 (decode-opcode #b11100111 8
699 (lambda (opcode)
700 (short-relative-branch opcode "bnn" negative-flag?)))
702 (decode-opcode #b11100101 8
703 (lambda (opcode)
704 (short-relative-branch opcode "bnov"
705 (lambda ()
706 (not (overflow-flag?))))))
708 (decode-opcode #b11100001 8
709 (lambda (opcode)
710 (short-relative-branch opcode "bnz"
711 (lambda ()
712 (not (zero-flag?))))))
714 (decode-opcode #b11100100 8
715 (lambda (opcode)
716 (short-relative-branch opcode "bov" overflow-flag?)))
718 (decode-opcode #b11010 11
719 (lambda (opcode)
720 (long-relative-branch opcode "bra" #f)))
722 (decode-opcode #b11100000 8
723 (lambda (opcode)
724 (short-relative-branch opcode "bz" zero-flag?)))
726 (decode-opcode #b1110110 9
727 (lambda (opcode)
728 (call-branch opcode "call")))
730 (decode-opcode #b11101111 8
731 (lambda (opcode)
732 (goto-branch opcode "goto")))
734 (decode-opcode #b11011 11
735 (lambda (opcode)
736 (long-relative-branch opcode "rcall" #t)))
738 (decode-opcode #b1111 12
739 (lambda (opcode)
740 (if trace-instr
741 (print (list (last-pc) " nop ")))))
743 (decode-opcode #b00000000 8
744 (lambda (opcode)
745 (cond ((= opcode #b0000000000000100)
746 (if trace-instr
747 (print (list (last-pc) " clrwdt ")))
748 (clrwdt opcode))
749 ((= opcode #b0000000000000111)
750 (if trace-instr
751 (print (list (last-pc) " daw ")))
752 (daw opcode))
753 ((= opcode #b0000000000000000)
754 (if trace-instr
755 (print (list (last-pc) " nop "))))
756 ((= opcode #b0000000000000110)
757 (if trace-instr
758 (print (list (last-pc) " pop ")))
759 (stack-pop))
760 ((= opcode #b0000000000000101)
761 (if trace-instr
762 (print (list (last-pc) " push ")))
763 (stack-push (get-pc)))
764 ((= opcode #b0000000011111111)
765 (if trace-instr
766 (print (list (last-pc) " reset ")))
767 (set-pc 0))
768 ((= opcode #b0000000000010000)
769 (if trace-instr
770 (print (list (last-pc) " retfie ")))
771 (get-program-mem)
772 (stack-pop))
773 ((= opcode #b0000000000010001)
774 (if trace-instr
775 (print (list (last-pc) " retfie FAST")))
776 (error "retfie fast not implemented")
777 (get-program-mem)
778 (stack-pop))
779 ((= opcode #b0000000000010010)
780 (if trace-instr
781 (print (list (last-pc) " return ")))
782 (get-program-mem)
783 (stack-pop))
784 ((= opcode #b0000000000010011)
785 (if trace-instr
786 (print (list (last-pc) " return FAST")))
787 (error "return fast not implemented")
788 (get-program-mem)
789 (stack-pop))
790 ((= opcode #b0000000000000011)
791 (if trace-instr
792 (print (list (last-pc) " sleep ")))
793 (set! pic18-exit #t))
794 ;; program memory operations
795 ((= opcode #b0000000000001000)
796 (program-memory-read "tblrd*" identity identity))
797 ((= opcode #b0000000000001001)
798 (program-memory-read "tblrd*+" identity (lambda (adr) (+ adr 1))))
799 ((= opcode #b0000000000001010)
800 (program-memory-read "tblrd*-" identity (lambda (adr) (- adr 1))))
801 ((= opcode #b0000000000001011)
802 (program-memory-read "tblrd+*"
803 (lambda (adr) (+ adr 1))
804 (lambda (adr) (+ adr 1))))
805 ((= opcode #b0000000000001100)
806 (program-memory-write "tblwt*" identity identity)) ;; TODO not implemented
807 ((= opcode #b0000000000001101)
808 (program-memory-write "tblwt*+" identity (lambda (adr) (+ adr 1))))
809 ((= opcode #b0000000000001110)
810 (program-memory-write "tblwt*-" identity (lambda (adr) (- adr 1))))
811 ((= opcode #b0000000000001111)
812 (program-memory-write "tblwt+*"
813 (lambda (adr) (+ adr 1))
814 (lambda (adr) (+ adr 1))))
815 (else
816 (if trace-instr
817 (print (list (last-pc) " ??? ")))
818 (error "???")))))
820 ; Literal operations.
822 (decode-opcode #b00001111 8
823 (lambda (opcode)
824 (literal-operation opcode "addlw" 'c-dc-z-ov-n
825 (lambda (k)
826 (+ k (get-wreg))))))
828 (decode-opcode #b00001011 8
829 (lambda (opcode)
830 (literal-operation opcode "andlw" 'z-n
831 (lambda (k)
832 (bitwise-and k (get-wreg))))))
834 (decode-opcode #b00001001 8
835 (lambda (opcode)
836 (literal-operation opcode "iorlw" 'z-n
837 (lambda (k)
838 (bitwise-ior k (get-wreg))))))
840 '
841 (define (lfsr f k)
842 (make-instruction
843 2
844 (lambda ()
845 (make-listing "lfsr" (file-text f) (lit-text k)))
846 (lambda ()
847 (asm-16 (bitmask "1110 1110 00ff kkkk" (file f) (quotient (lit k) 256)))
848 (asm-16 (bitmask "1111 0000 kkkk kkkk" (modulo (lit k) 256))))))
850 '
851 (define (movlb k)
852 (make-instruction
853 1
854 (lambda ()
855 (make-listing "movlb" (lit-text k)))
856 (lambda ()
857 (asm-16 (bitmask "0000 0001 0000 kkkk" (lit k))))))
859 (decode-opcode #b00001110 8
860 (lambda (opcode)
861 (literal-operation opcode "movlw" 'none
862 (lambda (k)
863 k))))
865 (decode-opcode #b00001101 8
866 (lambda (opcode)
867 (literal-operation opcode "mullw" 'none
868 (lambda (k)
869 (* k (get-wreg))))))
871 (decode-opcode #b00001100 8
872 (lambda (opcode)
873 (literal-operation opcode "retlw" 'none
874 (lambda (k)
875 (get-program-mem)
876 (stack-pop)
877 k))))
879 (decode-opcode #b00001000 8
880 (lambda (opcode)
881 (literal-operation opcode "sublw" 'c-dc-z-ov-n
882 (lambda (k)
883 (- k (get-wreg))))))
885 (decode-opcode #b00001010 8
886 (lambda (opcode)
887 (literal-operation opcode "xorlw" 'z-n
888 (lambda (k)
889 (bitwise-xor k (get-wreg))))))
892 ;------------------------------------------------------------------------------
894 (define (read-hex-file filename)
896 (define addr-width 32)
898 (define (syntax-error)
899 (error "*** Syntax error in HEX file"))
901 (let ((f
902 (with-exception-catcher
903 (lambda (exc)
904 #f)
905 (lambda ()
906 (open-input-file filename)))))
908 (define mem (make-vector 16 #f))
910 (define (mem-store! a b)
911 (let loop ((m mem)
912 (a a)
913 (x (- addr-width 4)))
914 (if (= x 0)
915 (vector-set! m a b)
916 (let ((i (arithmetic-shift a (- x))))
917 (let ((v (vector-ref m i)))
918 (loop (or v
919 (let ((v (make-vector 16 #f)))
920 (vector-set! m i v)
921 v))
922 (- a (arithmetic-shift i x))
923 (- x 4)))))))
925 (define (mem->list)
927 (define (f m a n tail)
929 (define (g i a n tail)
930 (if (>= i 0)
931 (g (- i 1) (- a n) n (f (vector-ref m i) a n tail))
932 tail))
934 (if m
935 (if (= n 1)
936 (cons (cons (- a 1) m) tail)
937 (g 15 a (quotient n 16) tail))
938 tail))
940 (f mem (expt 2 addr-width) (expt 2 addr-width) '()))
942 (define hi16
943 0)
945 (define (read-hex-nibble)
946 (let ((c (read-char f)))
947 (cond ((and (char>=? c #\0) (char<=? c #\9))
948 (- (char->integer c) (char->integer #\0)))
949 ((and (char>=? c #\A) (char<=? c #\F))
950 (+ 10 (- (char->integer c) (char->integer #\A))))
951 ((and (char>=? c #\a) (char<=? c #\f))
952 (+ 10 (- (char->integer c) (char->integer #\a))))
953 (else
954 (syntax-error)))))
956 (define (read-hex-byte)
957 (let* ((a (read-hex-nibble))
958 (b (read-hex-nibble)))
959 (+ b (* a 16))))
961 (if f
962 (begin
963 (let loop1 ()
964 (let ((c (read-char f)))
965 (cond ((not (char? c)))
966 ((or (char=? c #\linefeed)
967 (char=? c #\return))
968 (loop1))
969 ((not (char=? c #\:))
970 (syntax-error))
971 (else
972 (let* ((len (read-hex-byte))
973 (a1 (read-hex-byte))
974 (a2 (read-hex-byte))
975 (type (read-hex-byte)))
976 (let* ((adr (+ a2 (* 256 a1)))
977 (sum (+ len a1 a2 type)))
978 (cond ((= type 0)
979 (let loop2 ((i 0))
980 (if (< i len)
981 (let ((a (+ adr (* hi16 65536)))
982 (b (read-hex-byte)))
983 (mem-store! a b)
984 (set! adr (modulo (+ adr 1) 65536))
985 (set! sum (+ sum b))
986 (loop2 (+ i 1))))))
987 ((= type 1)
988 (if (not (= len 0))
989 (syntax-error)))
990 ((= type 4)
991 (if (not (= len 2))
992 (syntax-error))
993 (let* ((a1 (read-hex-byte))
994 (a2 (read-hex-byte)))
995 (set! sum (+ sum a1 a2))
996 (set! hi16 (+ a2 (* 256 a1)))))
997 (else
998 (syntax-error)))
999 (let ((check (read-hex-byte)))
1000 (if (not (= (modulo (- sum) 256) check))
1001 (syntax-error)))
1002 (let ((c (read-char f)))
1003 (if (or (not (or (char=? c #\linefeed)
1004 (char=? c #\return)))
1005 (not (= type 1)))
1006 (loop1)))))))))
1008 (close-input-port f)
1010 (mem->list))
1011 (begin
1012 (error "*** Could not open the HEX file")
1013 #f))))
1015 ;------------------------------------------------------------------------------
1017 (define (execute-hex-files . filenames)
1018 (let ((programs (map read-hex-file filenames)))
1019 (pic18-sim-setup)
1020 (for-each (lambda (prog)
1021 (for-each (lambda (x) (set-rom (car x) (cdr x)))
1022 prog))
1023 programs)
1024 (pic18-execute)
1025 (pic18-sim-cleanup)))
1027 (define (show-profiling-data) ;; TODO temporary solution until we have the true profile working
1028 (with-input-from-file asm-filename
1029 (lambda ()
1030 (let loop ((line (read-line)))
1031 (if (not (eq? line #!eof))
1032 (begin (if (not (eq? (string-ref line 0) #\tab)) ; not a label
1033 (let ((adr (string->number (car (split-string line
1034 #\space))
1035 16)))
1036 (print (list (vector-ref instrs-counts adr)
1037 " "))))
1038 (print (list line "\n"))
1039 (loop (read-line))))))))
1040 (define (dump-profiling-data file)
1041 (with-output-to-file file show-profiling-data))
1043 ;; debugging procedures
1044 (define (add-break-point adr) (set! break-points (cons adr break-points)))
1045 (define (continue) (set! single-stepping-mode? #f)) ;; TODO + the equivalent of ,c
1047 (define (picobit-object o0 o1)
1048 (define (obj->ram o field)
1049 (get-ram (+ 512 (arithmetic-shift (- o 512) 2) field)))
1050 (define (ram-get-car o) ;; TODO shouldn't end up seeing any rom objects
1051 (bitwise-ior (arithmetic-shift (bitwise-and (obj->ram o 0) #x1f) 8)
1052 (obj->ram o 1)))
1053 (define (ram-get-cdr o)
1054 (bitwise-ior (arithmetic-shift (bitwise-and (obj->ram o 2) #x1f) 8)
1055 (obj->ram o 3)))
1056 (define (ram-get-entry o)
1057 (bitwise-ior (arithmetic-shift (bitwise-and (obj->ram o 0) #x1f) 11)
1058 (arithmetic-shift (obj->ram o 1) 3)
1059 (arithmetic-shift (obj->ram o 2) -5)))
1061 (define (show-pair ptr)
1062 (let ((obj (ram-get-car ptr))
1063 (next (ram-get-cdr ptr)))
1064 (show-obj obj)
1065 (cond ((= next 2)) ; '()
1066 ((and (> next 511) (< next 1280) ; ram
1067 (= (bitwise-and (obj->ram next 0) #x80) #x80) ; composite
1068 (= (bitwise-and (obj->ram next 2) #xe0) 0)) ; pair
1069 (display " ")
1070 (show-pair next))
1071 (else (display " . ")
1072 (show-obj next)))))
1074 (define (show-obj o)
1075 (cond ((= o 0) (display #f))
1076 ((= o 1) (display #t))
1077 ((= o 2) (display '()))
1078 ((< o (+ 3 255 1 1)) ; fixnum
1079 (display (- o 4)))
1080 ((< o 512) ; rom
1081 (display "rom")) ;; TODO be more precise, since we should end up with a rom object, the quoted list
1082 ((< o 1280)
1083 (let ((obj (bitwise-ior (arithmetic-shift (obj->ram o 0) 24)
1084 (arithmetic-shift (obj->ram o 1) 16)
1085 (arithmetic-shift (obj->ram o 2) 8)
1086 (obj->ram o 3))))
1087 (cond ((= (bitwise-and obj #xc0000000) 0)
1088 (display "ram-bignum"))
1089 ((= (bitwise-and obj #x80000000) #x80000000) ; ram composite
1090 (cond ((= (bitwise-and obj #x0000e000) 0) ; ram pair
1091 (display "(")
1092 (show-pair o)
1093 (display ")"))
1094 ((= (bitwise-and obj #x0000e000) #x2000)
1095 (display "#<symbol>"))
1096 ((= (bitwise-and obj #x0000e000) #x4000)
1097 (display "#<string>"))
1098 ((= (bitwise-and obj #x0000e000) #x6000)
1099 (display "#<vector>"))
1100 ((= (bitwise-and obj #x0000e000) #x8000)
1101 (display "#<cont: ")
1102 (show-obj (ram-get-cdr o))
1103 (display " ")
1104 (show-obj (ram-get-car o))
1105 (display ">"))
1106 (else (display "unknown?"))))
1107 (else
1108 (display (string-append "{0x"
1109 (number->string (ram-get-entry o)
1110 16)
1111 " "))
1112 (show-obj (ram-get-cdr o))
1113 (display "}")))))
1114 (else (display "invalid"))))
1116 (show-obj (+ (* 256 (get-ram o1)) (get-ram o0)))
1117 (display "\n"))
1119 (define (picobit-pc)
1120 (number->string (+ (* 256 (get-ram (table-ref reverse-register-table
1121 "pc1$88")))
1122 (get-ram (table-ref reverse-register-table
1123 "pc0$89")))
1124 16))
1125 (define (picobit-stack)
1126 (picobit-object (table-ref reverse-register-table "env0$86")
1127 (table-ref reverse-register-table "env1$85")))
1128 (define (picobit-continuation)
1129 (picobit-object (table-ref reverse-register-table "cont0$84")
1130 (table-ref reverse-register-table "cont1$83")))