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))
  22     ;; we might have to access the second bank
  23     (emit (if (outside-bank-0? file)
  24               (if d?
  25                   (list op (- file 96) 'f 'b)
  26                   (list op (- file 96) 'b))
  27               (if d?
  28                   (list op file '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)
  41     (let ((i (car rev-code)))
  42       (list-set! i 2 'w) ; destination is w, not f
  43       i))
  44   (define (movff src dst)
  45     (emit (list 'movff src dst)))
  46
  47   (define (clrf adr)
  48     (emit-byte-oriented 'clrf adr #f))
  49   (define (setf adr)
  50     (emit-byte-oriented 'setf adr #f))
  51
  52   (define (incf adr)
  53     (emit-byte-oriented 'incf adr))
  54   (define (decf adr)
  55     (emit-byte-oriented 'decf adr))
  56
  57   (define (addwf adr)
  58     (emit-byte-oriented 'addwf adr))
  59   (define (addwfc adr)
  60     (emit-byte-oriented 'addwfc adr))
  61
  62   (define (subwf adr)
  63     (emit-byte-oriented 'subwf adr))
  64   (define (subwfb adr)
  65     (emit-byte-oriented 'subwfb adr))
  66
  67   (define (mullw adr)
  68     (emit (list 'mullw adr)))
  69   (define (mulwf adr)
  70     (emit-byte-oriented 'mulwf adr #f))
  71
  72   (define (andwf adr)
  73     (emit-byte-oriented 'andwf adr))
  74   (define (iorwf adr)
  75     (emit-byte-oriented 'iorwf adr))
  76   (define (xorwf adr)
  77     (emit-byte-oriented 'xorwf adr))
  78
  79   (define (rlcf adr)
  80     (emit-byte-oriented 'rlcf adr))
  81   (define (rrcf adr)
  82     (emit-byte-oriented 'rrcf adr))
  83
  84   (define (bcf adr bit)
  85     (emit-bit-oriented 'bcf adr bit))
  86   (define (bsf adr bit)
  87     (emit-bit-oriented 'bsf adr bit))
  88   (define (btg adr bit)
  89     (emit-bit-oriented 'btg adr bit))
  90
  91   (define (comf adr)
  92     (emit-byte-oriented 'comf adr))
  93
  94   (define (tblrd) ;; TODO support the different modes
  95     (emit (list 'tblrd)))
  96
  97   (define (cpfseq adr)
  98     (emit-byte-oriented 'cpfseq adr #f))
  99   (define (cpfslt adr)
 100     (emit-byte-oriented 'cpfslt adr #f))
 101   (define (cpfsgt adr)
 102     (emit-byte-oriented 'cpfsgt adr #f))
 103
 104   (define (bra label)
 105     (emit (list 'bra label)))
 106
 107   (define (rcall label)
 108     (emit (list 'rcall label)))
 109
 110   (define (return)
 111     (if (and #f (and (not (null? rev-code))
 112                      (eq? (caar rev-code) 'rcall)))
 113         (let ((label (cadar rev-code)))
 114           (set! rev-code (cdr rev-code))
 115           (bra label))
 116         (emit (list 'return))))
 117
 118   (define (label lab)
 119     (if (and #f (and (not (null? rev-code))
 120                      (eq? (caar rev-code) 'bra)
 121                      (eq? (cadar rev-code) lab)))
 122         (begin
 123           (set! rev-code (cdr rev-code))
 124           (label lab))
 125         (emit (list 'label lab))))
 126
 127   (define (sleep)
 128     (emit (list 'sleep)))
 129
 130   (define (move-reg src dst)
 131     (cond ((= src dst))
 132           ((= src WREG)
 133            (movwf dst))
 134           ((= dst WREG)
 135            (movfw src))
 136           (else
 137            ;;         (movfw src)
 138            ;;         (movwf dst)
 139            ;; takes 2 cycles (as much as movfw src ; movwf dst), but takes
 140            ;; only 1 instruction
 141            (movff src dst))))
 142
 143   (define (bb-linearize bb)
 144     (let ((label-num (bb-label-num bb)))
 145       (let ((bb (vector-ref bbs-vector label-num)))
 146
 147         (define (move-lit n adr)
 148           (cond ((= n 0)
 149                  (clrf adr))
 150                 ((= n #xff)
 151                  (setf adr))
 152                 (else
 153                  (movlw n)
 154                  (movwf adr))))
 155
 156         (define (dump-instr instr)
 157           (cond ((call-instr? instr)
 158                  (let* ((def-proc (call-instr-def-proc instr))
 159                         (entry (def-procedure-entry def-proc)))
 160                    (if (bb? entry)
 161                        (begin
 162                          (add-todo entry)
 163                          (let ((label (bb-label entry)))
 164                            (rcall label)))
 165                        (rcall entry))))
 166                 ((return-instr? instr)
 167                  (return))
 168                 (else
 169                  (let ((src1 (instr-src1 instr))
 170                        (src2 (instr-src2 instr))
 171                        (dst (instr-dst instr)))
 172                    (if (and (or (not (byte-cell? dst))
 173                                 (byte-cell-adr dst))
 174                             (or (not (byte-cell? src1))
 175                                 (byte-cell-adr src1))
 176                             (or (not (byte-cell? src2))
 177                                 (byte-cell-adr src2)))
 178
 179                        (case (instr-id instr)
 180
 181                          ((move)
 182                           (if (byte-lit? src1)
 183                               (let ((n (byte-lit-val src1))
 184                                     (z (byte-cell-adr dst)))
 185                                 (move-lit n z))
 186                               (let ((x (byte-cell-adr src1))
 187                                     (z (byte-cell-adr dst)))
 188                                 (move-reg x z))))
 189
 190                          ((add addc sub subb)
 191                           (if (byte-lit? src2)
 192                               (let ((n (byte-lit-val src2))
 193                                     (z (byte-cell-adr dst)))
 194                                 (if (byte-lit? src1)
 195                                     (move-lit (byte-lit-val src1) z)
 196                                     (move-reg (byte-cell-adr src1) z))
 197                                 (case (instr-id instr)
 198                                   ((add)  (cond ((= n 1)    (incf z))
 199                                                 ((= n #xff) (decf z))
 200                                                 (else       (movlw n)
 201                                                             (addwf z))))
 202                                   ((addc) (movlw n) (addwfc z))
 203                                   ((sub)  (cond ((= n 1)    (decf z))
 204                                                 ((= n #xff) (incf z))
 205                                                 (else       (movlw n)
 206                                                             (subwf z))))
 207                                   ((subb) (movlw n) (subwfb z))))
 208                               (let ((x (byte-cell-adr src1))
 209                                     (y (byte-cell-adr src2))
 210                                     (z (byte-cell-adr dst)))
 211                                 (cond ((and (not (= x y))
 212                                             (= y z)
 213                                             (memq (instr-id instr)
 214                                                   '(add addc)))
 215                                        ;; since this basically swaps the
 216                                        ;; arguments, it can't be used for
 217                                        ;; subtraction
 218                                        (move-reg x WREG))
 219                                       ((and (not (= x y))
 220                                             (= y z))
 221                                        ;; for subtraction, preserves argument
 222                                        ;; order
 223                                        (move-reg y WREG)
 224                                        ;; this NEEDS to be done with movff, or
 225                                        ;; else wreg will get clobbered and this
 226                                        ;; won't work
 227                                        (move-reg x z))
 228                                       (else ;; TODO check if it could be merged with the previous case
 229                                        (move-reg x z)
 230                                        (move-reg y WREG)))
 231                                 (case (instr-id instr)
 232                                   ((add)  (addwf z))
 233                                   ((addc) (addwfc z))
 234                                   ((sub)  (subwf z))
 235                                   ((subb) (subwfb z))
 236                                   (else   (error "..."))))))
 237
 238                          ((mul) ; 8 by 8 multiplication
 239                           (if (byte-lit? src2)
 240                               ;; since multiplication is commutative, the
 241                               ;; arguments are set up so the second one will
 242                               ;; be a literal if the operator is applied on a
 243                               ;; literal and a variable
 244                               (let ((n (byte-lit-val src2)))
 245                                 (if (byte-lit? src1)
 246                                     (movlw   (byte-lit-val src1))
 247                                     (move-reg (byte-cell-adr src1) WREG))
 248                                 ;; literal multiplication
 249                                 (mullw n))
 250                               (let ((x (byte-cell-adr src1))
 251                                     (y (byte-cell-adr src2)))
 252                                 (move-reg x WREG)
 253                                 (mulwf y))))
 254
 255                          ((and ior xor)
 256                           ;; no instructions for bitwise operations involving
 257                           ;; literals exist on the PIC18
 258                           (let ((x (if (byte-lit? src1)
 259                                        (byte-lit-val src1)
 260                                        (byte-cell-adr src1)))
 261                                 (y (if (byte-lit? src2)
 262                                        (byte-lit-val src2)
 263                                        (byte-cell-adr src2)))
 264                                 (z (byte-cell-adr dst)))
 265                             (cond ((byte-lit? src1)
 266                                    (if (byte-lit? src2)
 267                                        (move-lit y z)
 268                                        (move-reg y z))
 269                                    (movlw x))
 270                                   ((and (not (= x y)) (= y z))
 271                                    (move-reg x WREG))
 272                                   (else
 273                                    (move-reg x z)
 274                                    (move-reg y WREG)))
 275                             (case (instr-id instr)
 276                               ((and) (andwf z))
 277                               ((ior) (iorwf z))
 278                               ((xor) (xorwf z))
 279                               (else (error "...")))))
 280
 281                          ((shl shr)
 282                           (let ((x (if (byte-lit? src1)
 283                                        (byte-lit-val src1)
 284                                        (byte-cell-adr src1)))
 285                                 (z (byte-cell-adr dst)))
 286                             (cond ((byte-lit? src1) (move-lit x z))
 287                                   ((not (= x z))    (move-reg x z)))
 288                             (case (instr-id instr)
 289                               ((shl) (rlcf z))
 290                               ((shr) (rrcf z)))))
 291
 292                          ((set clear toggle)
 293                           ;; bit operations
 294                           (if (not (byte-lit? src2))
 295                               (error "bit offset must be a literal"))
 296                           (let ((x (byte-cell-adr src1))
 297                                 (y (byte-lit-val src2)))
 298                             (case (instr-id instr)
 299                               ((set)    (bsf x y))
 300                               ((clear)  (bcf x y))
 301                               ((toggle) (btg x y)))))
 302
 303                          ((not)
 304                           (let ((z (byte-cell-adr dst)))
 305                             (if (byte-lit? src1)
 306                                 (move-lit (byte-lit-val  src1) z)
 307                                 (move-reg (byte-cell-adr src1) z))
 308                             (comf z)))
 309
 310                          ((tblrd)
 311                           (if (byte-lit? src1)
 312                               (move-lit (byte-lit-val  src1) TBLPTRL)
 313                               (move-reg (byte-cell-adr src1) TBLPTRL))
 314                           (if (byte-lit? src2)
 315                               (move-lit (byte-lit-val  src2) TBLPTRH)
 316                               (move-reg (byte-cell-adr src2) TBLPTRH))
 317                           ;; TODO the 5 high bytes are not used for now
 318                           (tblrd))
 319
 320                          ((goto)
 321                           (if (null? (bb-succs bb))
 322                               (error "I think you might have given me an empty source file."))
 323                           (let* ((succs (bb-succs bb))
 324                                  (dest (car succs)))
 325                             (bra (bb-label dest))
 326                             (add-todo dest)))
 327                          ((x==y x<y x>y)
 328                           (let* ((succs (bb-succs bb))
 329                                  (dest-true (car succs))
 330                                  (dest-false (cadr succs)))
 331
 332                             (define (compare flip adr)
 333                               (case (instr-id instr)
 334                                 ((x<y) (if flip (cpfsgt adr) (cpfslt adr)))
 335                                 ((x>y) (if flip (cpfslt adr) (cpfsgt adr)))
 336                                 (else (cpfseq adr)))
 337                               (bra (bb-label dest-false))
 338                               (bra (bb-label dest-true))
 339                               (add-todo dest-false)
 340                               (add-todo dest-true))
 341
 342                             (cond ((byte-lit? src1)
 343                                    (let ((n (byte-lit-val src1))
 344                                          (y (byte-cell-adr src2)))
 345                                      (if #f #;(and (or (= n 0) (= n 1) (= n #xff))
 346                                          (eq? (instr-id instr) 'x==y))
 347                                          (special-compare-eq-lit n x)
 348                                          (begin
 349                                            (movlw n)
 350                                            (compare #t y)))))
 351                             ((byte-lit? src2)
 352                              (let ((x (byte-cell-adr src1))
 353                                    (n (byte-lit-val src2)))
 354                                (if #f #;(and (or (= n 0) (= n 1) (= n #xff))
 355                                    (eq? (instr-id instr) 'x==y))
 356                                    (special-compare-eq-lit n x)
 357                                    (begin
 358                                      (movlw n)
 359                                      (compare #f x)))))
 360                           (else
 361                            (let ((x (byte-cell-adr src1))
 362                                  (y (byte-cell-adr src2)))
 363                              (move-reg y WREG)
 364                              (compare #f x))))))
 365                    (else
 366                                         ;...
 367                     (emit (list (instr-id instr))))))))))
 368
 369     (if bb
 370         (begin
 371           (vector-set! bbs-vector label-num #f)
 372           (label (bb-label bb))
 373           (for-each dump-instr (reverse (bb-rev-instrs bb)))
 374           (for-each add-todo (bb-succs bb)))))))
 375
 376 (let ((prog-label (asm-make-label 'PROG)))
 377   (rcall prog-label)
 378   (sleep)
 379   (label prog-label))
 380
 381 (add-todo (vector-ref bbs-vector 0))
 382
 383 (let loop ()
 384   (if (null? todo)
 385       (reverse rev-code)
 386       (let ((bb (car todo)))
 387         (set! todo (cdr todo))
 388         (bb-linearize bb)
 389         (loop)))))
 390
 391
 392 (define (assembler-gen filename cfg)
 393
 394   (define (gen instr)
 395     (define (gen-1-arg)
 396       ((eval (car instr)) (cadr instr)))
 397     (define (gen-2-args)
 398       ((eval (car instr)) (cadr instr) (caddr instr)))
 399     (define (gen-3-args)
 400       ((eval (car instr)) (cadr instr) (caddr instr) (cadddr instr)))
 401     (case (car instr)
 402       ((movlw mullw)
 403        (gen-1-arg))
 404       ((movff movwf clrf setf cpfseq cpfslt cpfsgt mulwf)
 405        (gen-2-args))
 406       ((incf decf addwf addwfc subwf subwfb andwf iorwf xorwf rlcf rrcf comf
 407         bcf bsf btg movf)
 408        (gen-3-args))
 409       ((tblrd)
 410        (tblrd*)) ;; TODO support the other modes
 411       ((bra)
 412        (bra-or-goto (cadr instr)))
 413       ((rcall)
 414        (rcall-or-call (cadr instr)))
 415       ((return)
 416        (return))
 417       ((label)
 418        (asm-listing
 419         (string-append (symbol->string (asm-label-id (cadr instr))) ":"))
 420        (asm-label (cadr instr)))
 421       ((sleep)
 422        (sleep))
 423       (else
 424        (error "unknown instruction" instr))))
 425
 426   (asm-begin! 0 #f)
 427
 428   ;; (pretty-print cfg)
 429
 430   (let ((code (linearize-and-cleanup cfg)))
 431     ;; (pretty-print code)
 432     ;; if we would need a second bank, load the address for the second bank in BSR
 433     (if bank-1-used?
 434         (begin (gen (list 'movlw 1))
 435                (gen (list 'movwf BSR 'a))))
 436     (for-each gen code)))