code-generation.scm

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