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