pic18-sim.scm

   1 ;;; File: "pic18-sim.scm"
   2
   3 (define pic18-ram   #f)
   4 (define pic18-rom   #f)
   5 (define pic18-stack #f)
   6 (define pic18-pc    #f)
   7 (define pic18-wreg  #f)
   8
   9 (define instrs-counts #f) ; counts how many times each instruction is executed
  10 (define break-points '()) ; list of adresses at which the simulation stops
  11
  12 (define pic18-carry-flag    #f)
  13 (define pic18-deccarry-flag #f)
  14 (define pic18-zero-flag     #f)
  15 (define pic18-overflow-flag #f)
  16 (define pic18-negative-flag #f)
  17
  18 (define pic18-cycles #f)
  19 (define pic18-exit #f)
  20
  21 (define (get-ram adr)
  22   (cond ((= adr TOSU)
  23          (bitwise-and (arithmetic-shift (get-tos) -16) #xff))
  24         ((= adr TOSH)
  25          (bitwise-and (arithmetic-shift (get-tos) -8) #xff))
  26         ((= adr TOSL)
  27          (bitwise-and (get-tos) #xff))
  28         ((= adr PCL)
  29          (set-ram PCLATU (bitwise-and (arithmetic-shift (get-pc) -16) #x1f))
  30          (set-ram PCLATH (bitwise-and (arithmetic-shift (get-pc) -8)  #xff))
  31          (bitwise-and (get-pc) #xfe))
  32         ((= adr STATUS)
  33          (+ pic18-carry-flag
  34             (arithmetic-shift pic18-deccarry-flag 1)
  35             (arithmetic-shift pic18-zero-flag 2)
  36             (arithmetic-shift pic18-overflow-flag 3)
  37             (arithmetic-shift pic18-negative-flag 4)))
  38         ((assq adr (list (cons INDF0 (cons FSR0H FSR0L))
  39                          (cons INDF1 (cons FSR1H FSR1L))
  40                          (cons INDF2 (cons FSR2H FSR2L))))
  41          => (lambda (x)
  42               (get-ram (bitwise-ior
  43                         (arithmetic-shift (bitwise-and (u8vector-ref pic18-ram
  44                                                                      (cadr x))
  45                                                        #xf)
  46                                           8)
  47                         (u8vector-ref pic18-ram
  48                                       (cddr x))))))
  49         ;; TODO pre/post inc/dec 0..2
  50         (else
  51          (u8vector-ref pic18-ram adr))))
  52
  53 (define (set-ram adr byte)
  54   (cond ((= adr TOSU)
  55          (set-tos (+ (bitwise-and (get-tos) #x00ffff)
  56                      (arithmetic-shift (bitwise-and byte #x1f) 16))))
  57         ((= adr TOSH)
  58          (set-tos (+ (bitwise-and (get-tos) #x1f00ff)
  59                      (arithmetic-shift byte 8))))
  60         ((= adr TOSL)
  61          (set-tos (+ (bitwise-and (get-tos) #x1fff00)
  62                      byte)))
  63         ((= adr PCL)
  64          (set-pc (+ (bitwise-and (arithmetic-shift (get-ram PCLATU) 16) #x1f)
  65                     (bitwise-and (arithmetic-shift (get-ram PCLATH) 8) #xff)
  66                     (bitwise-and byte #xfe))))
  67         ((= adr STATUS)
  68          (set! pic18-carry-flag    (bitwise-and byte 1))
  69          (set! pic18-deccarry-flag (arithmetic-shift (bitwise-and byte 2) -1))
  70          (set! pic18-zero-flag     (arithmetic-shift (bitwise-and byte 4) -2))
  71          (set! pic18-overflow-flag (arithmetic-shift (bitwise-and byte 8) -3))
  72          (set! pic18-negative-flag (arithmetic-shift (bitwise-and byte 16) -4)))
  73         ((assq adr (list (cons INDF0 (cons FSR0H FSR0L))
  74                          (cons INDF1 (cons FSR1H FSR1L))
  75                          (cons INDF2 (cons FSR2H FSR2L))))
  76          => (lambda (x)
  77               (set-ram (bitwise-ior ;; TODO factor common code with get-ram ?
  78                         (arithmetic-shift (bitwise-and (u8vector-ref pic18-ram
  79                                                                      (cadr x))
  80                                                        #xf)
  81                                           8)
  82                         (u8vector-ref pic18-ram
  83                                       (cddr x)))
  84                        byte)))
  85         ;; TODO all other special array registers
  86         (else
  87          (u8vector-set! pic18-ram adr byte))))
  88
  89 (define (get-rom adr)
  90   (u8vector-ref pic18-rom adr))
  91
  92 (define (set-rom adr byte)
  93   (u8vector-set! pic18-rom adr byte))
  94
  95 (define (get-stack adr)
  96   (vector-ref pic18-stack adr))
  97
  98 (define (set-stack adr pc)
  99   (vector-set! pic18-stack adr pc))
 100
 101 (define (get-pc)
 102   pic18-pc)
 103
 104 (define (set-pc pc)
 105   (set! pic18-pc pc))
 106
 107 (define (get-sp)
 108   (bitwise-and (get-ram STKPTR) #x1f))
 109
 110 (define (set-sp sp)
 111   (set-ram STKPTR
 112            (bitwise-ior sp
 113                         (bitwise-and (get-ram STKPTR) #xe0))))
 114
 115 (define (get-tos)
 116   (vector-ref pic18-stack (- (get-sp) 1)))
 117
 118 (define (set-tos pc)
 119   (vector-set! pic18-stack (- (get-sp) 1) pc))
 120
 121 (define (stack-push pc)
 122   (set-sp (+ (get-sp) 1))
 123   (set-tos pc))
 124
 125 (define (stack-pop)
 126   (set-pc (get-tos))
 127   (set-sp (- (get-sp) 1)))
 128
 129 (define (get-bsr)
 130   (bitwise-and (get-ram BSR) #x0f))
 131
 132 (define (get-wreg)
 133   pic18-wreg)
 134
 135 (define (set-wreg byte)
 136   (set! pic18-wreg byte))
 137
 138 (define (zero-flag?)
 139   (not (= 0 pic18-zero-flag)))
 140
 141 (define (set-zero-flag flag)
 142   (set! pic18-zero-flag flag))
 143
 144 (define (negative-flag?)
 145   (not (= 0 pic18-negative-flag)))
 146
 147 (define (set-negative-flag flag)
 148   (set! pic18-negative-flag flag))
 149
 150 (define (carry-flag?)
 151   (not (= 0 pic18-carry-flag)))
 152
 153 (define (set-carry-flag flag)
 154   (set! pic18-carry-flag flag))
 155
 156 (define (deccarry-flag?)
 157   (not (= 0 pic18-deccarry-flag)))
 158
 159 (define (set-deccarry-flag flag)
 160   (set! pic18-deccarry-flag flag))
 161
 162 (define (overflow-flag?)
 163   (not (= 0 pic18-overflow-flag)))
 164
 165 (define (set-overflow-flag flag)
 166   (set! pic18-overflow-flag flag))
 167
 168 (define (pic18-sim-setup)
 169   (set! pic18-ram     (make-u8vector #x1000  0))
 170   (set! pic18-rom     (make-u8vector #x10000 0))
 171   (set! pic18-stack   (make-vector   #x1f    0))
 172   (set! instrs-counts (make-vector   #x10000 0))
 173   (set-pc 0)
 174   (set-wreg 0)
 175   (set! pic18-carry-flag    0)
 176   (set! pic18-deccarry-flag 0)
 177   (set! pic18-zero-flag     0)
 178   (set! pic18-overflow-flag 0)
 179   (set! pic18-negative-flag 0))
 180
 181 (define (pic18-sim-cleanup)
 182   (set! pic18-ram   #f)
 183   (set! pic18-rom   #f)
 184   (set! pic18-stack #f))
 185
 186 ;------------------------------------------------------------------------------
 187
 188 (define (last-pc)
 189   (let ((pc (- (get-pc) 2)))
 190     (list (get-sp) " " (- pic18-cycles 1) " "
 191           (substring (number->string (+ #x1000000 pc) 16) 1 7)
 192           "     ")))
 193
 194 (define (illegal-opcode opcode)
 195   (if trace-instr
 196       (print (list (last-pc) "  *illegal*")))
 197   (error "illegal opcode" opcode))
 198
 199 (define decode-vector
 200   (make-vector 256 illegal-opcode))
 201
 202 (define (decode-opcode opcode-bits shift action)
 203   (if (< shift 8)
 204       (error "shift=" shift))
 205   (let ((n (arithmetic-shift 1 (- shift 8)))
 206         (base (arithmetic-shift opcode-bits (- shift 8))))
 207     (let loop ((i 0))
 208       (if (< i n)
 209           (begin
 210             (vector-set! decode-vector (+ base i) action)
 211             (loop (+ i 1)))))))
 212
 213 (define (byte-oriented opcode mnemonic flags-changed operation)
 214   (byte-oriented-aux opcode mnemonic flags-changed operation 'wreg))
 215 (define (byte-oriented-file opcode mnemonic flags-changed operation)
 216   (byte-oriented-aux opcode mnemonic flags-changed operation 'file))
 217 (define (byte-oriented-wide opcode mnemonic flags-changed operation dest)
 218   ;; for use with instructions that have results more than a byte wide, such
 219   ;; as multiplication. the result goes at the given addresses
 220   (byte-oriented-aux opcode mnemonic flags-changed operation dest)) ;; TODO do the same for literals
 221
 222 (define (byte-oriented-aux opcode mnemonic flags-changed operation dest)
 223   (let* ((f (bitwise-and opcode #xff))
 224          (adr (if (= 0 (bitwise-and opcode #x100))
 225                   ;; the upper 160 addresses of the first bank are the special
 226                   ;; registers #xF60 to #xFFF
 227                   (if (= 0 (bitwise-and f #x80)) f (+ f #xf00))
 228                   (+ f (arithmetic-shift (get-bsr) 8)))))
 229     (if trace-instr
 230         (print (list (last-pc) "        " mnemonic "    "
 231                        (let ((x (assv adr file-reg-names)))
 232                          (if x
 233                              (cdr x)
 234                              (let ((x (table-ref register-table f #f)))
 235                                (if #f ;x ;; TODO unreadable with picobit
 236                                    (apply string-append-with-separator (cons "/" x))
 237                                    (list "0x" (number->string adr 16))))))
 238                        (if (or (eq? dest 'wreg)
 239                                (= 0 (bitwise-and opcode #x200)))
 240                            ", w"
 241                            "")
 242                        "")))
 243     (let* ((result (operation (get-ram adr)))
 244            (result-8bit (bitwise-and result #xff)))
 245       (cond ((list? dest)
 246              ;; result is more than a byte wide (i.e. multiplication)
 247              ;; put it in the right destinations (dest is a list of addresses)
 248              (let loop ((dest dest) (result result))
 249                (if (not (null? dest))
 250                    ;; the head of the list is the lsb
 251                    (begin (set-ram (car dest) (bitwise-and result #xff))
 252                           (loop (cdr dest) (arithmetic-shift result -8))))))
 253             ((or (eq? dest 'file) (not (= 0 (bitwise-and opcode #x200))))
 254              ;; the result goes in memory (file)
 255              (set-ram adr result-8bit))
 256             ((eq? dest 'wreg)
 257              ;; result goes in wreg
 258              (set-wreg result-8bit)))
 259       (if (not (eq? flags-changed 'none))
 260           (begin
 261             (set-zero-flag (if (= 0 result-8bit) 1 0))
 262             (if (not (eq? flags-changed 'z))
 263                 (begin
 264                   (set-negative-flag (if (> result-8bit #x7f) 1 0))
 265                   (if (not (eq? flags-changed 'z-n))
 266                       (begin
 267                         (set-carry-flag (if (or (> result #xff)
 268                                                 (< result 0))
 269                                             1 0))
 270                         (if (not (eq? flags-changed 'c-z-n))
 271                             (begin
 272                               (set-deccarry-flag 0);;;;;;;;;;;;;;
 273                               (set-overflow-flag 0))))))))))));;;;;;;;;;;;;;
 274
 275 (define (bit-oriented opcode mnemonic operation)
 276   (let* ((f (bitwise-and opcode #xff))
 277          (adr (if (= 0 (bitwise-and opcode #x100))
 278                   (if (= 0 (bitwise-and f #x80)) f (+ f #xf00))
 279                   (+ f (arithmetic-shift (get-bsr) 8))))
 280          (b (bitwise-and (arithmetic-shift opcode -9) 7)))
 281     (if trace-instr
 282         (print (list (last-pc) "        " mnemonic "    "
 283                        (let ((x (assv adr file-reg-names)))
 284                          (if x (cdr x) (list "0x" (number->string adr 16))))
 285                        ", "
 286                        (if (= adr STATUS)
 287                            (cdr (assv b '((0 . C)
 288                                           (1 . DC)
 289                                           (2 . Z)
 290                                           (3 . OV)
 291                                           (4 . N)
 292                                           (5 . 5)
 293                                           (6 . 6)
 294                                           (7 . 7))))
 295                            b)
 296                        "")))
 297     (let* ((result (operation (get-ram adr) b))
 298            (result-8bit (bitwise-and result #xff)))
 299       (set-ram adr result-8bit))))
 300
 301 (define (short-relative-branch opcode mnemonic branch)
 302   (let* ((n (bitwise-and opcode #xff))
 303          (adr (+ (get-pc) (* 2 (if (> n #x7f) (- n #x100) n)))))
 304     (if trace-instr
 305         (print (list (last-pc) "        " mnemonic "    "
 306                      (symbol->string (table-ref symbol-table adr)))))
 307     (if (branch)
 308         (begin
 309           (get-program-mem)
 310           (set-pc adr)))))
 311
 312 (define (long-relative-branch opcode mnemonic call?)
 313   (let* ((n (bitwise-and opcode #x7ff))
 314          (adr (+ (get-pc) (* 2 (if (> n #x3ff) (- n #x800) n)))))
 315     (if trace-instr
 316         (print (list (last-pc) "        " mnemonic "    "
 317                      (symbol->string (table-ref symbol-table adr)))))
 318     (if call?
 319         (stack-push (get-pc)))
 320     (get-program-mem)
 321     (set-pc adr)))
 322
 323 (define (call-branch opcode mnemonic)
 324   (let ((adr (* 2 (+ (bitwise-and opcode #xff)
 325                      (arithmetic-shift (bitwise-and (get-program-mem) #xfff) 8)))))
 326     (if trace-instr
 327         (print (list (last-pc) "        " mnemonic "    "
 328                      (symbol->string (table-ref symbol-table adr))
 329                      (if (= 0 (bitwise-and opcode #x100))
 330                          ""
 331                          ", FAST"))))
 332     (stack-push (get-pc))
 333     (if (not (= 0 (bitwise-and opcode #x100)))
 334         (error "call fast not implemented"))
 335     (set-pc adr)))
 336
 337 (define (goto-branch opcode mnemonic)
 338   (let ((adr (* 2 (+ (bitwise-and opcode #xff)
 339                      (arithmetic-shift (bitwise-and (get-program-mem) #xfff) 8)))))
 340     (if trace-instr
 341         (print (list (last-pc) "        " mnemonic "    "
 342                      (symbol->string (table-ref symbol-table adr)))))
 343     (set-pc adr)))
 344
 345 (define (literal-operation opcode mnemonic flags-changed operation)
 346   (let ((k (bitwise-and opcode #xff)))
 347     (if trace-instr
 348         (print (list (last-pc) "        " mnemonic "    "
 349                        (if (< k 10) k (list "0x" (number->string k 16))))))
 350     (let* ((result (operation k))
 351            (result-8bit (bitwise-and result #xff)))
 352       (set-wreg result-8bit)
 353       (if (not (eq? flags-changed 'none))
 354           (begin
 355             (set-zero-flag (if (= 0 result-8bit) 1 0))
 356             (if (not (eq? flags-changed 'z))
 357                 (begin
 358                   (set-negative-flag (if (> result-8bit #x7f) 1 0))
 359                   (if (not (eq? flags-changed 'z-n))
 360                       (begin
 361                         (set-carry-flag (if (> result #xff) 1 0))
 362                         (if (not (eq? flags-changed 'c-z-n))
 363                             (begin
 364                               (set-deccarry-flag 0);;;;;;;;;;;;;;
 365                               (set-overflow-flag 0))))))))))));;;;;;;;;;;;;;
 366
 367 (define (program-memory-read mnemonic read-adr-fun set-adr-fun)
 368   (if trace-instr
 369       (print (list (last-pc) "  " mnemonic "    ")))
 370   (let ((adr (bitwise-ior (arithmetic-shift (get-ram TBLPTRU) 16)
 371                           (arithmetic-shift (get-ram TBLPTRH) 8)
 372                           (get-ram TBLPTRL))))
 373     (set-ram TABLAT (get-rom (bitwise-and (read-adr-fun adr)
 374                                           ;; rom addresses are 21 bits wide
 375                                           #x1fffff)))
 376     (let ((new-adr (bitwise-and (set-adr-fun adr) #x1fffff)))
 377       (set-ram TBLPTRU (arithmetic-shift new-adr -16))
 378       (set-ram TBLPTRH (bitwise-and (arithmetic-shift new-adr -8) #xff))
 379       (set-ram TBLPTRL (bitwise-and new-adr #xff)))))
 380
 381 (define (get-program-mem)
 382   (set! pic18-cycles (+ pic18-cycles 1))
 383   (let* ((pc (get-pc))
 384          (lsb (get-rom pc))
 385          (msb (get-rom (+ pc 1))))
 386     (set-pc (+ (get-pc) 2))
 387     (+ (arithmetic-shift msb 8) lsb)))
 388
 389 (define (skip)
 390   (get-program-mem))
 391
 392 (define (hex n)
 393   (substring (number->string (+ #x100 n) 16) 1 3))
 394
 395 (define (dump-mem)
 396
 397   (print "      ")
 398   (let loop ((i 0))
 399     (if (< i 10)
 400         (begin
 401           (print (list (hex (u8vector-ref pic18-ram i)) " "))
 402           (loop (+ i 1)))))
 403   (print (list "  WREG=" (hex (get-wreg)) "\n")))
 404
 405 (define single-stepping-mode? #f)
 406 (define (pic18-execute)
 407   (set! pic18-exit #f)
 408   (set! pic18-cycles 0)
 409   (if trace-instr
 410       (print "                          "))
 411   (let loop ()
 412     (if trace-instr
 413         (dump-mem))
 414     (if pic18-exit
 415         (begin
 416           (print (list "WREG = d'" (get-wreg) "'\n")))
 417         (let ((opcode (get-program-mem))
 418               (pc     (- (get-pc) 2)))
 419           (vector-set! instrs-counts pc (+ (vector-ref instrs-counts pc) 1))
 420           (if (member pc break-points)
 421               (begin (pp (list "break point at: " (number->string pc 16)))
 422                      (set! trace-instr #t)
 423                      (set! single-stepping-mode? #t)))
 424           (if single-stepping-mode? (step))
 425           (let ((proc (vector-ref decode-vector (arithmetic-shift opcode -8))))
 426             (proc opcode)
 427             (loop))))))
 428
 429 (define trace-instr #t)
 430
 431 (define (carry)
 432   (if (> pic18-carry-flag 0)
 433       (begin (set! pic18-carry-flag #f)
 434              1)
 435       0))
 436
 437 ;------------------------------------------------------------------------------
 438
 439 ; Byte-oriented file register operations.
 440
 441 (decode-opcode #b001001 10
 442   (lambda (opcode)
 443     (byte-oriented opcode "addwf" 'c-dc-z-ov-n
 444      (lambda (f)
 445        (+ f (get-wreg))))))
 446
 447 (decode-opcode #b001000 10
 448   (lambda (opcode)
 449     (byte-oriented opcode "addwfc" 'c-dc-z-ov-n
 450      (lambda (f)
 451        (+ f (get-wreg) (carry))))))
 452
 453 (decode-opcode #b000101 10
 454   (lambda (opcode)
 455     (byte-oriented opcode "andwf" 'z-n
 456      (lambda (f)
 457        (bitwise-and f (get-wreg))))))
 458
 459 (decode-opcode #b0110101 9
 460   (lambda (opcode)
 461     (byte-oriented-file opcode "clrf" 'z
 462      (lambda (f)
 463        0))))
 464
 465 (decode-opcode #b000111 10
 466   (lambda (opcode)
 467     (byte-oriented opcode "comf" 'z-n
 468      (lambda (f)
 469        (bitwise-not f)))))
 470
 471 (decode-opcode #b0110001 9
 472   (lambda (opcode)
 473     (byte-oriented-file opcode "cpfseq" 'none
 474      (lambda (f)
 475        (if (= f (get-wreg)) (skip))
 476        f))))
 477
 478 (decode-opcode #b0110010 9
 479   (lambda (opcode)
 480     (byte-oriented-file opcode "cpfsgt" 'none
 481      (lambda (f)
 482        (if (> f (get-wreg)) (skip))
 483        f))))
 484
 485 (decode-opcode #b0110000 9
 486   (lambda (opcode)
 487     (byte-oriented-file opcode "cpfslt" 'none
 488      (lambda (f)
 489        (if (< f (get-wreg)) (skip))
 490        f))))
 491
 492 (decode-opcode #b000001 10
 493   (lambda (opcode)
 494     (byte-oriented opcode "decf" 'c-dc-z-ov-n
 495      (lambda (f)
 496        (- f 1)))))
 497
 498 (decode-opcode #b001011 10
 499   (lambda (opcode)
 500     (byte-oriented opcode "decfsz" 'none
 501      (lambda (f)
 502        (if (= f 1) (skip))
 503        (- f 1)))))
 504
 505 (decode-opcode #b010011 10
 506   (lambda (opcode)
 507     (byte-oriented opcode "dcfsnz" 'none
 508      (lambda (f)
 509        (if (not (= f 1)) (skip))
 510        (- f 1)))))
 511
 512 (decode-opcode #b001010 10
 513   (lambda (opcode)
 514     (byte-oriented opcode "incf" 'c-dc-z-ov-n
 515      (lambda (f)
 516        (+ f 1)))))
 517
 518 (decode-opcode #b001111 10
 519   (lambda (opcode)
 520     (byte-oriented opcode "incfsz" 'none
 521      (lambda (f)
 522        (if (= f #xff) (skip))
 523        (+ f 1)))))
 524
 525 (decode-opcode #b010010 10
 526   (lambda (opcode)
 527     (byte-oriented opcode "infsnz" 'none
 528      (lambda (f)
 529        (if (not (= f #xff)) (skip))
 530        (+ f 1)))))
 531
 532 (decode-opcode #b000100 10
 533   (lambda (opcode)
 534     (byte-oriented opcode "iorwf" 'z-n
 535      (lambda (f)
 536        (bitwise-ior f (get-wreg))))))
 537
 538 (decode-opcode #b010100 10
 539   (lambda (opcode)
 540     (byte-oriented opcode "movf" 'z-n
 541      (lambda (f)
 542        f))))
 543
 544 (decode-opcode #b1100 12
 545   (lambda (opcode)
 546     (let* ((src (bitwise-and opcode #xfff))
 547            ;; the destination is in the second 16-bit part, need to fetch
 548            (dst (bitwise-and (get-program-mem) #xfff)))
 549       (if trace-instr
 550           (print (list (last-pc) "      movff   "
 551                        (let ((x (assv src file-reg-names)))
 552                          (if x (cdr x) (list "0x" (number->string src 16))))
 553                        ", "
 554                        (let ((x (assv dst file-reg-names)))
 555                          (if x (cdr x) (list "0x" (number->string dst 16)))) ;; TODO printing 2 args ruins the formatting
 556                        "")))
 557       (set-ram dst (get-ram src)))))
 558
 559 (decode-opcode #b0110111 9
 560   (lambda (opcode)
 561     (byte-oriented-file opcode "movwf" 'none
 562      (lambda (f)
 563        (get-wreg)))))
 564
 565 (decode-opcode #b0000001 9
 566   (lambda (opcode)
 567     (byte-oriented-wide opcode "mulwf" 'none
 568      (lambda (f)
 569        (* f (get-wreg)))
 570      (list PRODL PRODH))))
 571
 572 (decode-opcode #b0110110 9
 573   (lambda (opcode)
 574     (byte-oriented-file opcode "negf" 'c-dc-z-ov-n
 575      (lambda (f)
 576        (- f)))))
 577
 578 (decode-opcode #b001101 10
 579   (lambda (opcode)
 580     (byte-oriented opcode "rlcf" 'c-z-n
 581      (lambda (f)
 582        ;; the carry flag will be set automatically
 583        (+ (arithmetic-shift f 1) (carry))))))
 584
 585 (decode-opcode #b010001 10
 586   (lambda (opcode)
 587     (byte-oriented opcode "rlncf" 'z-n
 588      (lambda (f)
 589        (+ (arithmetic-shift f 1) (arithmetic-shift f -7))))))
 590
 591 (decode-opcode #b001100 10
 592   (lambda (opcode)
 593     (byte-oriented opcode "rrcf" 'c-z-n
 594      (lambda (f)
 595        (let ((r (+ (arithmetic-shift f -1) (arithmetic-shift (carry) 7))))
 596          ;; roll through carry (if the result is over #xff, carry will be set)
 597          (if (= (bitwise-and f 1) 1) (+ r #x100) r))))))
 598
 599 (decode-opcode #b010000 10
 600   (lambda (opcode)
 601     (byte-oriented opcode "rrncf" 'z-n
 602      (lambda (f)
 603        (+ (arithmetic-shift f -1) (arithmetic-shift f 7))))))
 604
 605 (decode-opcode #b0110100 9
 606   (lambda (opcode)
 607     (byte-oriented-file opcode "setf" 'z
 608      (lambda (f)
 609        #xff))))
 610
 611 (decode-opcode #b010101 10
 612   (lambda (opcode)
 613     (byte-oriented opcode "subfwb" 'c-dc-z-ov-n
 614      (lambda (f)
 615        (- (get-wreg) f (carry))))))
 616
 617 (decode-opcode #b010111 10
 618   (lambda (opcode)
 619     (byte-oriented opcode "subwf" 'c-dc-z-ov-n
 620      (lambda (f)
 621        (- f (get-wreg))))))
 622
 623 (decode-opcode #b010110 10
 624   (lambda (opcode)
 625     (byte-oriented opcode "subwfb" 'c-dc-z-ov-n
 626      (lambda (f)
 627        (- f (get-wreg) (carry))))))
 628
 629 (decode-opcode #b001110 10
 630   (lambda (opcode)
 631     (byte-oriented opcode "swapf" 'none
 632      (lambda (f)
 633        (+ (arithmetic-shift f -4) (arithmetic-shift f 4))))))
 634
 635 (decode-opcode #b0110011 9
 636   (lambda (opcode)
 637     (byte-oriented-file opcode "tstfsz" 'none
 638      (lambda (f)
 639        (if (= f 0) (skip))))))
 640
 641 (decode-opcode #b000110 10
 642   (lambda (opcode)
 643     (byte-oriented opcode "xorwf" 'z-n
 644      (lambda (f)
 645        (bitwise-xor f (get-wreg))))))
 646
 647 ; Bit-oriented file register operations.
 648
 649 (decode-opcode #b1001 12
 650   (lambda (opcode)
 651     (bit-oriented opcode "bcf"
 652      (lambda (f b)
 653        (bitwise-and f (bitwise-not (arithmetic-shift 1 b)))))))
 654
 655 (decode-opcode #b1000 12
 656   (lambda (opcode)
 657     (bit-oriented opcode "bsf"
 658      (lambda (f b)
 659        (bitwise-ior f (arithmetic-shift 1 b))))))
 660
 661 (decode-opcode #b1011 12
 662   (lambda (opcode)
 663     (bit-oriented opcode "btfsc"
 664      (lambda (f b)
 665        (if (= 0 (bitwise-and f (arithmetic-shift 1 b))) (skip))
 666        f))))
 667
 668 (decode-opcode #b1010 12
 669   (lambda (opcode)
 670     (bit-oriented opcode "btfss"
 671      (lambda (f b)
 672        (if (not (= 0 (bitwise-and f (arithmetic-shift 1 b)))) (skip))
 673        f))))
 674
 675 (decode-opcode #b0111 12
 676   (lambda (opcode)
 677     (bit-oriented opcode "btg"
 678      (lambda (f b)
 679        (bitwise-xor f (arithmetic-shift 1 b))))))
 680
 681 ; Control operations.
 682
 683 (decode-opcode #b11100010 8
 684   (lambda (opcode)
 685     (short-relative-branch opcode "bc"
 686      (lambda ()
 687        (not (= 0 (carry)))))))
 688
 689 (decode-opcode #b11100110 8
 690   (lambda (opcode)
 691     (short-relative-branch opcode "bn" negative-flag?)))
 692
 693 (decode-opcode #b11100011 8
 694   (lambda (opcode)
 695     (short-relative-branch opcode "bnc"
 696      (lambda ()
 697        (= 0 (carry))))))
 698
 699 (decode-opcode #b11100111 8
 700   (lambda (opcode)
 701     (short-relative-branch opcode "bnn" negative-flag?)))
 702
 703 (decode-opcode #b11100101 8
 704   (lambda (opcode)
 705     (short-relative-branch opcode "bnov"
 706      (lambda ()
 707        (not (overflow-flag?))))))
 708
 709 (decode-opcode #b11100001 8
 710   (lambda (opcode)
 711     (short-relative-branch opcode "bnz"
 712      (lambda ()
 713        (not (zero-flag?))))))
 714
 715 (decode-opcode #b11100100 8
 716   (lambda (opcode)
 717     (short-relative-branch opcode "bov" overflow-flag?)))
 718
 719 (decode-opcode #b11010 11
 720   (lambda (opcode)
 721     (long-relative-branch opcode "bra" #f)))
 722
 723 (decode-opcode #b11100000 8
 724   (lambda (opcode)
 725     (short-relative-branch opcode "bz" zero-flag?)))
 726
 727 (decode-opcode #b1110110 9
 728   (lambda (opcode)
 729     (call-branch opcode "call")))
 730
 731 (decode-opcode #b11101111 8
 732   (lambda (opcode)
 733     (goto-branch opcode "goto")))
 734
 735 (decode-opcode #b11011 11
 736   (lambda (opcode)
 737     (long-relative-branch opcode "rcall" #t)))
 738
 739 (decode-opcode #b1111 12
 740   (lambda (opcode)
 741     (if trace-instr
 742         (print (list (last-pc) "        nop     ")))))
 743
 744 (decode-opcode #b00000000 8
 745   (lambda (opcode)
 746     (cond ((= opcode #b0000000000000100)
 747            (if trace-instr
 748                (print (list (last-pc) " clrwdt  ")))
 749            (clrwdt opcode))
 750           ((= opcode #b0000000000000111)
 751            (if trace-instr
 752                (print (list (last-pc) " daw     ")))
 753            (daw opcode))
 754           ((= opcode #b0000000000000000)
 755            (if trace-instr
 756                (print (list (last-pc) " nop     "))))
 757           ((= opcode #b0000000000000110)
 758            (if trace-instr
 759                (print (list (last-pc) " pop     ")))
 760            (stack-pop))
 761           ((= opcode #b0000000000000101)
 762            (if trace-instr
 763                (print (list (last-pc) " push    ")))
 764            (stack-push (get-pc)))
 765           ((= opcode #b0000000011111111)
 766            (if trace-instr
 767                (print (list (last-pc) " reset   ")))
 768            (set-pc 0))
 769           ((= opcode #b0000000000010000)
 770            (if trace-instr
 771                (print (list (last-pc) " retfie  ")))
 772            (get-program-mem)
 773            (stack-pop))
 774           ((= opcode #b0000000000010001)
 775            (if trace-instr
 776                (print (list (last-pc) " retfie  FAST")))
 777            (error "retfie fast not implemented")
 778            (get-program-mem)
 779            (stack-pop))
 780           ((= opcode #b0000000000010010)
 781            (if trace-instr
 782                (print (list (last-pc) " return  ")))
 783            (get-program-mem)
 784            (stack-pop))
 785           ((= opcode #b0000000000010011)
 786            (if trace-instr
 787                (print (list (last-pc) " return  FAST")))
 788            (error "return fast not implemented")
 789            (get-program-mem)
 790            (stack-pop))
 791           ((= opcode #b0000000000000011)
 792            (if trace-instr
 793                (print (list (last-pc) " sleep   ")))
 794            (set! pic18-exit #t))
 795           ;; program memory operations
 796           ((= opcode #b0000000000001000)
 797            (program-memory-read   "tblrd*"  identity identity))
 798           ((= opcode #b0000000000001001)
 799            (program-memory-read   "tblrd*+" identity (lambda (adr) (+ adr 1))))
 800           ((= opcode #b0000000000001010)
 801            (program-memory-read   "tblrd*-" identity (lambda (adr) (- adr 1))))
 802           ((= opcode #b0000000000001011)
 803            (program-memory-read   "tblrd+*"
 804                                   (lambda (adr) (+ adr 1))
 805                                   (lambda (adr) (+ adr 1))))
 806           ((= opcode #b0000000000001100)
 807            (program-memory-write  "tblwt*"  identity identity)) ;; TODO not implemented
 808           ((= opcode #b0000000000001101)
 809            (program-memory-write  "tblwt*+" identity (lambda (adr) (+ adr 1))))
 810           ((= opcode #b0000000000001110)
 811            (program-memory-write  "tblwt*-" identity (lambda (adr) (- adr 1))))
 812           ((= opcode #b0000000000001111)
 813            (program-memory-write  "tblwt+*"
 814                                   (lambda (adr) (+ adr 1))
 815                                   (lambda (adr) (+ adr 1))))
 816           (else
 817            (if trace-instr
 818                (print (list (last-pc) " ???     ")))
 819            (error "???")))))
 820
 821 ; Literal operations.
 822
 823 (decode-opcode #b00001111 8
 824   (lambda (opcode)
 825     (literal-operation opcode "addlw" 'c-dc-z-ov-n
 826      (lambda (k)
 827        (+ k (get-wreg))))))
 828
 829 (decode-opcode #b00001011 8
 830   (lambda (opcode)
 831     (literal-operation opcode "andlw" 'z-n
 832      (lambda (k)
 833        (bitwise-and k (get-wreg))))))
 834
 835 (decode-opcode #b00001001 8
 836   (lambda (opcode)
 837     (literal-operation opcode "iorlw" 'z-n
 838      (lambda (k)
 839        (bitwise-ior k (get-wreg))))))
 840
 841 '
 842 (define (lfsr f k)
 843   (make-instruction
 844    2
 845    (lambda ()
 846      (make-listing "lfsr" (file-text f) (lit-text k)))
 847    (lambda ()
 848      (asm-16 (bitmask "1110 1110 00ff kkkk" (file f) (quotient (lit k) 256)))
 849      (asm-16 (bitmask "1111 0000 kkkk kkkk" (modulo (lit k) 256))))))
 850
 851 '
 852 (define (movlb k)
 853   (make-instruction
 854    1
 855    (lambda ()
 856      (make-listing "movlb" (lit-text k)))
 857    (lambda ()
 858      (asm-16 (bitmask "0000 0001 0000 kkkk" (lit k))))))
 859
 860 (decode-opcode #b00001110 8
 861   (lambda (opcode)
 862     (literal-operation opcode "movlw" 'none
 863      (lambda (k)
 864        k))))
 865
 866 (decode-opcode #b00001101 8
 867   (lambda (opcode)
 868     (literal-operation opcode "mullw" 'none
 869      (lambda (k)
 870        (* k (get-wreg))))))
 871
 872 (decode-opcode #b00001100 8
 873   (lambda (opcode)
 874     (literal-operation opcode "retlw" 'none
 875      (lambda (k)
 876        (get-program-mem)
 877        (stack-pop)
 878        k))))
 879
 880 (decode-opcode #b00001000 8
 881   (lambda (opcode)
 882     (literal-operation opcode "sublw" 'c-dc-z-ov-n
 883      (lambda (k)
 884        (- k (get-wreg))))))
 885
 886 (decode-opcode #b00001010 8
 887   (lambda (opcode)
 888     (literal-operation opcode "xorlw" 'z-n
 889      (lambda (k)
 890        (bitwise-xor k (get-wreg))))))
 891
 892
 893 ;------------------------------------------------------------------------------
 894
 895 (define (read-hex-file filename)
 896
 897   (define addr-width 32)
 898
 899   (define (syntax-error)
 900     (error "*** Syntax error in HEX file"))
 901
 902   (let ((f
 903          (with-exception-catcher
 904           (lambda (exc)
 905             #f)
 906           (lambda ()
 907             (open-input-file filename)))))
 908
 909     (define mem (make-vector 16 #f))
 910
 911     (define (mem-store! a b)
 912       (let loop ((m mem)
 913                  (a a)
 914                  (x (- addr-width 4)))
 915         (if (= x 0)
 916             (vector-set! m a b)
 917             (let ((i (arithmetic-shift a (- x))))
 918               (let ((v (vector-ref m i)))
 919                 (loop (or v
 920                           (let ((v (make-vector 16 #f)))
 921                             (vector-set! m i v)
 922                             v))
 923                       (- a (arithmetic-shift i x))
 924                       (- x 4)))))))
 925
 926     (define (mem->list)
 927
 928       (define (f m a n tail)
 929
 930         (define (g i a n tail)
 931           (if (>= i 0)
 932               (g (- i 1) (- a n) n (f (vector-ref m i) a n tail))
 933               tail))
 934
 935         (if m
 936             (if (= n 1)
 937                 (cons (cons (- a 1) m) tail)
 938                 (g 15 a (quotient n 16) tail))
 939             tail))
 940
 941       (f mem (expt 2 addr-width) (expt 2 addr-width) '()))
 942
 943     (define hi16
 944       0)
 945
 946     (define (read-hex-nibble)
 947       (let ((c (read-char f)))
 948         (cond ((and (char>=? c #\0) (char<=? c #\9))
 949                (- (char->integer c) (char->integer #\0)))
 950               ((and (char>=? c #\A) (char<=? c #\F))
 951                (+ 10 (- (char->integer c) (char->integer #\A))))
 952               ((and (char>=? c #\a) (char<=? c #\f))
 953                (+ 10 (- (char->integer c) (char->integer #\a))))
 954               (else
 955                (syntax-error)))))
 956
 957     (define (read-hex-byte)
 958       (let* ((a (read-hex-nibble))
 959              (b (read-hex-nibble)))
 960         (+ b (* a 16))))
 961
 962     (if f
 963         (begin
 964           (let loop1 ()
 965             (let ((c (read-char f)))
 966               (cond ((not (char? c)))
 967                     ((or (char=? c #\linefeed)
 968                          (char=? c #\return))
 969                      (loop1))
 970                     ((not (char=? c #\:))
 971                      (syntax-error))
 972                     (else
 973                      (let* ((len (read-hex-byte))
 974                             (a1 (read-hex-byte))
 975                             (a2 (read-hex-byte))
 976                             (type (read-hex-byte)))
 977                        (let* ((adr (+ a2 (* 256 a1)))
 978                               (sum (+ len a1 a2 type)))
 979                          (cond ((= type 0)
 980                                 (let loop2 ((i 0))
 981                                   (if (< i len)
 982                                       (let ((a (+ adr (* hi16 65536)))
 983                                             (b (read-hex-byte)))
 984                                         (mem-store! a b)
 985                                         (set! adr (modulo (+ adr 1) 65536))
 986                                         (set! sum (+ sum b))
 987                                         (loop2 (+ i 1))))))
 988                                ((= type 1)
 989                                 (if (not (= len 0))
 990                                     (syntax-error)))
 991                                ((= type 4)
 992                                 (if (not (= len 2))
 993                                     (syntax-error))
 994                                 (let* ((a1 (read-hex-byte))
 995                                        (a2 (read-hex-byte)))
 996                                   (set! sum (+ sum a1 a2))
 997                                   (set! hi16 (+ a2 (* 256 a1)))))
 998                                (else
 999                                 (syntax-error)))
1000                          (let ((check (read-hex-byte)))
1001                            (if (not (= (modulo (- sum) 256) check))
1002                                (syntax-error)))
1003                          (let ((c (read-char f)))
1004                            (if (or (not (or (char=? c #\linefeed)
1005                                             (char=? c #\return)))
1006                                    (not (= type 1)))
1007                                (loop1)))))))))
1008
1009           (close-input-port f)
1010
1011           (mem->list))
1012         (begin
1013           (error "*** Could not open the HEX file")
1014           #f))))
1015
1016 ;------------------------------------------------------------------------------
1017
1018 (define (execute-hex-files . filenames)
1019   (let ((programs (map read-hex-file filenames)))
1020     (pic18-sim-setup)
1021     (for-each (lambda (prog)
1022                 (for-each (lambda (x) (set-rom (car x) (cdr x)))
1023                           prog))
1024               programs)
1025     (pic18-execute)
1026     (pic18-sim-cleanup)))
1027
1028 (define (show-profiling-data) ;; TODO temporary solution until we have the true profile working
1029   (with-input-from-file asm-filename
1030     (lambda ()
1031       (let loop ((line (read-line)))
1032         (if (not (eq? line #!eof))
1033             (begin (if (not (eq? (string-ref line 0) #\tab)) ; not a label
1034                        (let ((adr (string->number (car (split-string line
1035                                                                      #\space))
1036                                                   16)))
1037                          (print (list (vector-ref instrs-counts adr)
1038                                       " "))))
1039                    (print (list line "\n"))
1040                    (loop (read-line))))))))
1041 (define (dump-profiling-data file)
1042   (with-output-to-file file show-profiling-data))
1043
1044 ;; debugging procedures
1045 (define (add-break-point adr) (set! break-points (cons adr break-points)))
1046 (define (continue) (set! single-stepping-mode? #f)) ;; TODO + the equivalent of ,c