code-generation.scm

   1 (define bank-1-used? #f)
   2
   3 (define (linearize-and-cleanup cfg)
   4
   5   (define bbs-vector (cfg->vector cfg))
   6
   7   (define todo '())
   8
   9   (define (add-todo bb)
  10     (set! todo (cons bb todo)))
  11
  12   (define rev-code '())
  13
  14   (define (emit instr)
  15     (set! rev-code (cons instr rev-code)))
  16
  17   (define (outside-bank-0? adr)
  18     (if (and (> adr #x5F) (< adr #xF60)) ; not a special register
  19         (begin (set! bank-1-used? #t) #t)
  20         #f))
  21   (define (emit-byte-oriented op file #!optional (d? #t) (w? #f))
  22     ;; we might have to access the second bank
  23     (emit (if (outside-bank-0? file)
  24               (if d?
  25                   (list op (- file 96) (if w? 'w 'f) 'b)
  26                   (list op (- file 96) 'b))
  27               (if d?
  28                   (list op file (if w? 'w 'f) 'a)
  29                   (list op file 'a)))))
  30   (define (emit-bit-oriented op file bit)
  31     (emit (if (outside-bank-0? file)
  32               (list op (- file 96) bit 'b)
  33               (list op file        bit 'a))))
  34
  35   (define (movlw val)
  36     (emit (list 'movlw val)))
  37   (define (movwf adr)
  38     (emit-byte-oriented 'movwf adr #f))
  39   (define (movfw adr)
  40     (emit-byte-oriented 'movf adr #t #t))
  41   (define (movff src dst)
  42     ;; anything over #x5f is in the second bank (at #x100)
  43     (let ((src (if (outside-bank-0? src)
  44                    (+ src #xa0)
  45                    src))
  46           (dst (if (outside-bank-0? dst)
  47                    (+ dst #xa0)
  48                    dst)))
  49       (emit (list 'movff src dst))))
  50
  51   (define (clrf adr)
  52     (emit-byte-oriented 'clrf adr #f))
  53   (define (setf adr)
  54     (emit-byte-oriented 'setf adr #f))
  55
  56   (define (incf adr)
  57     (emit-byte-oriented 'incf adr))
  58   (define (decf adr)
  59     (emit-byte-oriented 'decf adr))
  60
  61   (define (addwf adr)
  62     (emit-byte-oriented 'addwf adr))
  63   (define (addwfc adr)
  64     (emit-byte-oriented 'addwfc adr))
  65
  66   (define (subwf adr)
  67     (emit-byte-oriented 'subwf adr))
  68   (define (subwfb adr)
  69     (emit-byte-oriented 'subwfb adr))
  70
  71   (define (mullw adr)
  72     (emit (list 'mullw adr)))
  73   (define (mulwf adr)
  74     (emit-byte-oriented 'mulwf adr #f))
  75
  76   (define (andwf adr)
  77     (emit-byte-oriented 'andwf adr))
  78   (define (iorwf adr)
  79     (emit-byte-oriented 'iorwf adr))
  80   (define (xorwf adr)
  81     (emit-byte-oriented 'xorwf adr))
  82
  83   (define (rlcf adr)
  84     (emit-byte-oriented 'rlcf adr))
  85   (define (rrcf adr)
  86     (emit-byte-oriented 'rrcf adr))
  87
  88   (define (bcf adr bit)
  89     (emit-bit-oriented 'bcf adr bit))
  90   (define (bsf adr bit)
  91     (emit-bit-oriented 'bsf adr bit))
  92   (define (btg adr bit)
  93     (emit-bit-oriented 'btg adr bit))
  94
  95   (define (comf adr)
  96     (emit-byte-oriented 'comf adr))
  97
  98   (define (tblrd) ;; TODO support the different modes
  99     (emit (list 'tblrd)))
 100
 101   (define (cpfseq adr)
 102     (emit-byte-oriented 'cpfseq adr #f))
 103   (define (cpfslt adr)
 104     (emit-byte-oriented 'cpfslt adr #f))
 105   (define (cpfsgt adr)
 106     (emit-byte-oriented 'cpfsgt adr #f))
 107
 108   (define (bc label)
 109     (emit (list 'bc label)))
 110   (define (bra-or-goto label)
 111     (emit (list 'bra-or-goto label)))
 112   (define (goto label)
 113     (emit (list 'goto label)))
 114
 115   (define (rcall label)
 116     (emit (list 'rcall label)))
 117
 118   (define (return)
 119     (if (and #f (and (not (null? rev-code))
 120                      (eq? (caar rev-code) 'rcall)))
 121         (let ((label (cadar rev-code)))
 122           (set! rev-code (cdr rev-code))
 123           (bra-or-goto label))
 124         (emit (list 'return))))
 125
 126   (define (label lab)
 127     (if (and #f (and (not (null? rev-code))
 128                      (eq? (caar rev-code) 'bra-or-goto)
 129                      (eq? (cadar rev-code) lab)))
 130         (begin
 131           (set! rev-code (cdr rev-code))
 132           (label lab))
 133         (emit (list 'label lab))))
 134
 135   (define (sleep)
 136     (emit (list 'sleep)))
 137
 138   (define (move-reg src dst)
 139     (cond ((= src dst))
 140           ((= src WREG)
 141            (movwf dst))
 142           ((= dst WREG)
 143            (movfw src))
 144           (else
 145            ;;         (movfw src)
 146            ;;         (movwf dst)
 147            ;; takes 2 cycles (as much as movfw src ; movwf dst), but takes
 148            ;; only 1 instruction
 149            (movff src dst))))
 150
 151   (define (bb-linearize bb)
 152     (let ((label-num (bb-label-num bb)))
 153       (let ((bb (vector-ref bbs-vector label-num)))
 154
 155         (define (move-lit n adr)
 156           (cond ((= n 0)
 157                  (clrf adr))
 158                 ((= n #xff)
 159                  (setf adr))
 160                 (else
 161                  (movlw n)
 162                  (movwf adr))))
 163
 164         (define (dump-instr instr)
 165           (cond ((call-instr? instr)
 166                  (let* ((def-proc (call-instr-def-proc instr))
 167                         (entry (def-procedure-entry def-proc)))
 168                    (if (bb? entry)
 169                        (begin
 170                          (add-todo entry)
 171                          (let ((label (bb-label entry)))
 172                            (rcall label)))
 173                        (rcall entry))))
 174                 ((return-instr? instr)
 175                  (return))
 176                 (else
 177                  (let ((src1 (instr-src1 instr))
 178                        (src2 (instr-src2 instr))
 179                        (dst (instr-dst instr)))
 180                    (if (and (or (not (byte-cell? dst))
 181                                 (byte-cell-adr dst))
 182                             (or (not (byte-cell? src1))
 183                                 (byte-cell-adr src1))
 184                             (or (not (byte-cell? src2))
 185                                 (byte-cell-adr src2)))
 186
 187                        (case (instr-id instr)
 188
 189                          ((move)
 190                           (if (byte-lit? src1)
 191                               (let ((n (byte-lit-val src1))
 192                                     (z (byte-cell-adr dst)))
 193                                 (move-lit n z))
 194                               (let ((x (byte-cell-adr src1))
 195                                     (z (byte-cell-adr dst)))
 196                                 (move-reg x z))))
 197
 198                          ((add addc sub subb)
 199                           (if (byte-lit? src2)
 200                               (let ((n  (byte-lit-val src2))
 201                                     (z  (byte-cell-adr dst))
 202                                     (id (instr-id instr)))
 203                                 (if (byte-lit? src1)
 204                                     (move-lit (byte-lit-val src1) z)
 205                                     (move-reg (byte-cell-adr src1) z))
 206                                 (if (not (and (= n 0) ; nop
 207                                               (or (eq? id 'add)
 208                                                   (eq? id 'sub))))
 209                                     (case id
 210                                       ((add)  (cond ((= n 1)    (incf z))
 211                                                     ((= n #xff) (decf z)) ;; TODO set the carry if needed ?
 212                                                     (else       (movlw n)
 213                                                                 (addwf z))))
 214                                       ((addc) (movlw n) (addwfc z))
 215                                       ((sub)  (cond ((= n 1)    (decf z))
 216                                                     ((= n #xff) (incf z)) ;; TODO same
 217                                                     (else       (movlw n)
 218                                                                 (subwf z))))
 219                                       ((subb) (movlw n) (subwfb z)))))
 220                               (let ((x (byte-cell-adr src1))
 221                                     (y (byte-cell-adr src2))
 222                                     (z (byte-cell-adr dst)))
 223                                 (cond ((and (not (= x y))
 224                                             (= y z)
 225                                             (memq (instr-id instr)
 226                                                   '(add addc)))
 227                                        ;; since this basically swaps the
 228                                        ;; arguments, it can't be used for
 229                                        ;; subtraction
 230                                        (move-reg x WREG))
 231                                       ((and (not (= x y))
 232                                             (= y z))
 233                                        ;; for subtraction, preserves argument
 234                                        ;; order
 235                                        (move-reg y WREG)
 236                                        ;; this NEEDS to be done with movff, or
 237                                        ;; else wreg will get clobbered and this
 238                                        ;; won't work
 239                                        (move-reg x z))
 240                                       (else ;; TODO check if it could be merged with the previous case
 241                                        (move-reg x z)
 242                                        (move-reg y WREG)))
 243                                 (case (instr-id instr)
 244                                   ((add)  (addwf z))
 245                                   ((addc) (addwfc z))
 246                                   ((sub)  (subwf z))
 247                                   ((subb) (subwfb z))
 248                                   (else   (error "..."))))))
 249
 250                          ((mul) ; 8 by 8 multiplication
 251                           (if (byte-lit? src2)
 252                               ;; since multiplication is commutative, the
 253                               ;; arguments are set up so the second one will
 254                               ;; be a literal if the operator is applied on a
 255                               ;; literal and a variable
 256                               (let ((n (byte-lit-val src2)))
 257                                 (if (byte-lit? src1)
 258                                     (movlw   (byte-lit-val src1))
 259                                     (move-reg (byte-cell-adr src1) WREG))
 260                                 ;; literal multiplication
 261                                 (mullw n))
 262                               (let ((x (byte-cell-adr src1))
 263                                     (y (byte-cell-adr src2)))
 264                                 (move-reg x WREG)
 265                                 (mulwf y))))
 266
 267                          ((and ior xor)
 268                           (let* ((x  (if (byte-lit? src1)
 269                                          (byte-lit-val src1)
 270                                          (byte-cell-adr src1)))
 271                                  (y  (if (byte-lit? src2)
 272                                          (byte-lit-val src2)
 273                                          (byte-cell-adr src2)))
 274                                  (z  (byte-cell-adr dst))
 275                                  (id (instr-id instr))
 276                                  (f  (case id
 277                                        ((and) andwf)
 278                                        ((ior) iorwf)
 279                                        ((xor) xorwf)
 280                                        (else (error "...")))))
 281                             (if (byte-lit? src2)
 282                                 (cond ((or (and (eq? id 'and) (= y #xff))
 283                                            (and (eq? id 'ior) (= y #x00)))
 284                                        ;; nop, just move the value
 285                                        (if (byte-lit? src1)
 286                                            (move-lit x z)
 287                                            (move-reg x z)))
 288                                       ((and (eq? id 'and) (= y #x00))
 289                                        (clrf z))
 290                                       ((and (eq? id 'ior) (= y #xff))
 291                                        (setf z))
 292                                       (else (if (byte-lit? src1)
 293                                                 (move-lit x z)
 294                                                 (move-reg x z))
 295                                             (movlw y)
 296                                             (f z)))
 297                                 (begin (if (and (not (= x y)) (= y z))
 298                                            (move-reg x WREG)
 299                                            (begin
 300                                              (move-reg x z)
 301                                              (move-reg y WREG)))
 302                                        (f z)))))
 303
 304                          ((shl shr)
 305                           (let ((x (if (byte-lit? src1)
 306                                        (byte-lit-val src1)
 307                                        (byte-cell-adr src1)))
 308                                 (z (byte-cell-adr dst)))
 309                             (cond ((byte-lit? src1) (move-lit x z))
 310                                   ((not (= x z))    (move-reg x z)))
 311                             (case (instr-id instr)
 312                               ((shl) (rlcf z))
 313                               ((shr) (rrcf z)))))
 314
 315                          ((set clear toggle)
 316                           ;; bit operations
 317                           (if (not (byte-lit? src2))
 318                               (error "bit offset must be a literal"))
 319                           (let ((x (byte-cell-adr src1))
 320                                 (y (byte-lit-val src2)))
 321                             (case (instr-id instr)
 322                               ((set)    (bsf x y))
 323                               ((clear)  (bcf x y))
 324                               ((toggle) (btg x y)))))
 325
 326                          ((not)
 327                           (let ((z (byte-cell-adr dst)))
 328                             (if (byte-lit? src1)
 329                                 (move-lit (byte-lit-val  src1) z)
 330                                 (move-reg (byte-cell-adr src1) z))
 331                             (comf z)))
 332
 333                          ((tblrd)
 334                           (if (byte-lit? src1)
 335                               (move-lit (byte-lit-val  src1) TBLPTRL)
 336                               (move-reg (byte-cell-adr src1) TBLPTRL))
 337                           (if (byte-lit? src2)
 338                               (move-lit (byte-lit-val  src2) TBLPTRH)
 339                               (move-reg (byte-cell-adr src2) TBLPTRH))
 340                           ;; TODO the 5 high bits are not used for now
 341                           (tblrd))
 342
 343                          ((goto)
 344                           (if (null? (bb-succs bb))
 345                               (error "I think you might have given me an empty source file."))
 346                           (let* ((succs (bb-succs bb))
 347                                  (dest (car succs)))
 348                             (bra-or-goto (bb-label dest))
 349                             (add-todo dest)))
 350                          ((x==y x<y x>y)
 351                           (let* ((succs (bb-succs bb))
 352                                  (dest-true (car succs))
 353                                  (dest-false (cadr succs)))
 354
 355                             (define (compare flip adr)
 356                               (case (instr-id instr)
 357                                 ((x<y) (if flip (cpfsgt adr) (cpfslt adr)))
 358                                 ((x>y) (if flip (cpfslt adr) (cpfsgt adr)))
 359                                 (else (cpfseq adr)))
 360                               (bra-or-goto (bb-label dest-false))
 361                               (bra-or-goto (bb-label dest-true))
 362                               (add-todo dest-false)
 363                               (add-todo dest-true))
 364
 365                             (cond ((byte-lit? src1)
 366                                    (let ((n (byte-lit-val src1))
 367                                          (y (byte-cell-adr src2)))
 368                                      (if #f #;(and (or (= n 0) (= n 1) (= n #xff))
 369                                          (eq? (instr-id instr) 'x==y))
 370                                          (special-compare-eq-lit n x)
 371                                          (begin
 372                                            (movlw n)
 373                                            (compare #t y)))))
 374                                   ((byte-lit? src2)
 375                                    (let ((x (byte-cell-adr src1))
 376                                          (n (byte-lit-val src2)))
 377                                      (if #f #;(and (or (= n 0) (= n 1) (= n #xff))
 378                                          (eq? (instr-id instr) 'x==y))
 379                                          (special-compare-eq-lit n x)
 380                                          (begin
 381                                            (movlw n)
 382                                            (compare #f x)))))
 383                                   (else
 384                                    (let ((x (byte-cell-adr src1))
 385                                          (y (byte-cell-adr src2)))
 386                                      (move-reg y WREG)
 387                                      (compare #f x))))))
 388
 389                          ((branch-if-carry)
 390                           (let* ((succs      (bb-succs bb))
 391                                  (dest-true  (car succs))
 392                                  (dest-false (cadr succs))
 393                                  ;; scratch is always a byte cell
 394                                  (scratch    (byte-cell-adr src1)))
 395                             ;; note : bc is too short for some cases
 396                             ;; (bc (bb-label dest-true))
 397                             ;; (bra-or-goto (bb-label dest-false))
 398                             ;; instead, we use scratch to indirectly test the
 399                             ;; carry and use regular branches
 400                             (clrf scratch)
 401                             (clrf WREG)
 402                             (addwfc scratch)
 403                             (cpfsgt scratch)
 404                             (bra-or-goto (bb-label dest-false))
 405                             (bra-or-goto (bb-label dest-true))))
 406
 407                          ((branch-table)
 408                           (let ((off     (if (byte-lit? src1) ; branch no
 409                                              (byte-lit-val  src1)
 410                                              (byte-cell-adr src1)))
 411                                 (scratch (byte-cell-adr src2))) ; working space
 412                             ;; precalculate the low byte of the PC
 413                             ;; note: both branches (off is a literal or a
 414                             ;; register) are of the same length in terms of
 415                             ;; code, which is important
 416                             (if (byte-lit? src1)
 417                                 (movlw off)
 418                                 (movfw off))
 419                             ;; we add 4 times the offset, since gotos are 4
 420                             ;; bytes long
 421                             (if (byte-lit? src1)
 422                                 (begin (movlw off)
 423                                        (movwf scratch))
 424                                 (movff off scratch))
 425                             (addwf scratch)
 426                             (addwf scratch)
 427                             (addwf scratch)
 428                             ;; to compensate for the PC advancing while we calculate
 429                             (movlw 10)
 430                             (addwf scratch)
 431                             (movfw PCL) ;; TODO at assembly, this can all be known statically
 432                             (addwf scratch)
 433                             (clrf WREG)
 434                             (addwfc PCLATH)
 435                             (movff scratch PCL)
 436
 437                             ;; create the jump table
 438                             (for-each (lambda (bb)
 439                                         (goto (bb-label bb))
 440                                         (add-todo bb))
 441                                       (bb-succs bb))))
 442
 443                    (else
 444                     ;; ...
 445                     (emit (list (instr-id instr))))))))))
 446
 447     (if bb
 448         (begin
 449           (vector-set! bbs-vector label-num #f)
 450           (label (bb-label bb))
 451           (for-each dump-instr (reverse (bb-rev-instrs bb)))
 452           (for-each add-todo (bb-succs bb)))))))
 453
 454 (let ((prog-label (asm-make-label 'PROG)))
 455   (rcall prog-label)
 456   (sleep)
 457   (label prog-label))
 458
 459 (add-todo (vector-ref bbs-vector 0))
 460
 461 (let loop ()
 462   (if (null? todo)
 463       (reverse rev-code)
 464       (let ((bb (car todo)))
 465         (set! todo (cdr todo))
 466         (bb-linearize bb)
 467         (loop)))))
 468
 469
 470 (define (assembler-gen filename cfg)
 471
 472   (define (gen instr)
 473     (define (gen-1-arg)
 474       ((eval (car instr)) (cadr instr)))
 475     (define (gen-2-args)
 476       ((eval (car instr)) (cadr instr) (caddr instr)))
 477     (define (gen-3-args)
 478       ((eval (car instr)) (cadr instr) (caddr instr) (cadddr instr)))
 479     (case (car instr)
 480       ((movlw mullw)
 481        (gen-1-arg))
 482       ((movff movwf clrf setf cpfseq cpfslt cpfsgt mulwf)
 483        (gen-2-args))
 484       ((incf decf addwf addwfc subwf subwfb andwf iorwf xorwf rlcf rrcf comf
 485         bcf bsf btg movf)
 486        (gen-3-args))
 487       ((tblrd)
 488        (tblrd*)) ;; TODO support the other modes
 489       ((bc)
 490        (bc (cadr instr)))
 491       ((bra)
 492        (bra (cadr instr)))
 493       ((goto)
 494        (goto (cadr instr)))
 495       ((bra-or-goto)
 496        (bra-or-goto (cadr instr)))
 497       ((rcall)
 498        (rcall-or-call (cadr instr)))
 499       ((return)
 500        (return))
 501       ((label)
 502        (asm-listing
 503         (string-append (symbol->string (asm-label-id (cadr instr))) ":"))
 504        (asm-label (cadr instr)))
 505       ((sleep)
 506        (sleep))
 507       (else
 508        (error "unknown instruction" instr))))
 509
 510   (asm-begin! 0 #f)
 511
 512   ;; (pretty-print cfg)
 513
 514   (let ((code (linearize-and-cleanup cfg)))
 515     ;; (pretty-print code)
 516     ;; if we would need a second bank, load the address for the second bank in BSR
 517     (if bank-1-used?
 518         (begin (gen (list 'movlw 1))
 519                (gen (list 'movwf BSR 'a))))
 520     (for-each gen code)))