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
  18   (define (movwf adr)
  19     (emit (list 'movwf adr)))
  20
  21   (define (movfw adr)
  22     (emit (list 'movfw adr)))
  23
  24   (define (clrf adr)
  25     (emit (list 'clrf adr)))
  26
  27   (define (setf adr)
  28     (emit (list 'setf adr)))
  29
  30   (define (incf adr)
  31     (emit (list 'incf adr)))
  32
  33   (define (decf adr)
  34     (emit (list 'decf adr)))
  35
  36   (define (addwf adr)
  37     (emit (list 'addwf adr)))
  38
  39   (define (addwfc adr)
  40     (emit (list 'addwfc adr)))
  41
  42   (define (subwf adr)
  43     (emit (list 'subwf adr)))
  44
  45   (define (subwfb adr)
  46     (emit (list 'subwfb adr)))
  47
  48   (define (cpfseq adr)
  49     (emit (list 'cpfseq adr)))
  50
  51   (define (cpfslt adr)
  52     (emit (list 'cpfslt adr)))
  53
  54   (define (cpfsgt adr)
  55     (emit (list 'cpfsgt adr)))
  56
  57   (define (bra label)
  58     (emit (list 'bra label)))
  59
  60   (define (rcall label)
  61     (emit (list 'rcall label)))
  62
  63   (define (return)
  64     (if (and #f (and (not (null? rev-code))
  65                      (eq? (caar rev-code) 'rcall)))
  66         (let ((label (cadar rev-code)))
  67           (set! rev-code (cdr rev-code))
  68           (bra label))
  69         (emit (list 'return))))
  70
  71   (define (label lab)
  72     (if (and #f (and (not (null? rev-code))
  73              (eq? (caar rev-code) 'bra)
  74              (eq? (cadar rev-code) lab)))
  75         (begin
  76           (set! rev-code (cdr rev-code))
  77           (label lab))
  78         (emit (list 'label lab))))
  79
  80   (define (sleep)
  81     (emit (list 'sleep)))
  82
  83   (define (move-reg src dst)
  84     (cond ((= src dst))
  85           ((= src WREG)
  86            (movwf dst))
  87           ((= dst WREG)
  88            (movfw src))
  89           (else
  90            (movfw src)
  91            (movwf dst))))
  92
  93   (define (bb-linearize bb)
  94     (let ((label-num (bb-label-num bb)))
  95       (let ((bb (vector-ref bbs-vector label-num)))
  96
  97         (define (move-lit n adr)
  98           (cond ((= n 0)
  99                  (clrf adr))
 100                 ((= n #xff)
 101                  (setf adr))
 102                 (else
 103                  (movlw n)
 104                  (movwf adr))))
 105
 106         (define (dump-instr instr)
 107           (cond ((call-instr? instr)
 108                  (let* ((def-proc (call-instr-def-proc instr))
 109                         (entry (def-procedure-entry def-proc)))
 110                    (if (bb? entry)
 111                        (begin
 112                          (add-todo entry)
 113                          (let ((label (bb-label entry)))
 114                            (rcall label)))
 115                        (rcall entry))))
 116                 ((return-instr? instr)
 117                  (return))
 118                 (else
 119                  (let ((src1 (instr-src1 instr))
 120                        (src2 (instr-src2 instr))
 121                        (dst (instr-dst instr)))
 122                    (if (and (or (not (byte-cell? dst))
 123                                 (byte-cell-adr dst))
 124                             (or (not (byte-cell? src1))
 125                                 (byte-cell-adr src1))
 126                             (or (not (byte-cell? src2))
 127                                 (byte-cell-adr src2)))
 128                        (case (instr-id instr)
 129                          ((move)
 130                           (if (byte-lit? src1)
 131                               (let ((n (byte-lit-val src1))
 132                                     (z (byte-cell-adr dst)))
 133                                 (move-lit n z))
 134                               (let ((x (byte-cell-adr src1))
 135                                     (z (byte-cell-adr dst)))
 136                                 (move-reg x z))))
 137                          ((add addc sub subb)
 138                           (if (byte-lit? src2)
 139                               (let ((n (byte-lit-val src2))
 140                                     (z (byte-cell-adr dst)))
 141                                 (if (byte-lit? src1)
 142                                     (move-lit (byte-lit-val src1) z)
 143                                     (move-reg (byte-cell-adr src1) z))
 144                                 (case (instr-id instr)
 145                                   ((add)
 146                                    (cond ((= n 1)
 147                                           (incf z))
 148                                          ((= n #xff)
 149                                           (decf z))
 150                                          (else
 151                                           (movlw n)
 152                                           (addwf z))))
 153                                   ((addc)
 154                                    (movlw n)
 155                                    (addwfc z))
 156                                   ((sub)
 157                                    (cond ((= n 1)
 158                                           (decf z))
 159                                          ((= n #xff)
 160                                           (incf z))
 161                                          (else
 162                                           (movlw n)
 163                                           (subwf z))))
 164                                   ((subb)
 165                                    (movlw n)
 166                                    (subwfb z))))
 167                               (let ((x (byte-cell-adr src1))
 168                                     (y (byte-cell-adr src2))
 169                                     (z (byte-cell-adr dst)))
 170                                 (cond ((and (not (= x y)) (= y z))
 171                                        (move-reg x WREG)
 172                                        (case (instr-id instr)
 173                                          ((add)
 174                                           (addwf z))
 175                                          ((addc)
 176                                           (addwfc z))
 177                                          ((sub)
 178                                           (subwfr z))
 179                                          ((subb)
 180                                           (subwfbr z))
 181                                          (else (error "..."))))
 182                                       (else
 183                                        (move-reg x z)
 184                                        (move-reg y WREG)
 185                                        (case (instr-id instr)
 186                                          ((add)
 187                                           (addwf z))
 188                                          ((addc)
 189                                           (addwfc z))
 190                                          ((sub)
 191                                           (subwf z))
 192                                          ((subb)
 193                                           (subwfb z))
 194                                          (else (error "..."))))))))
 195                          ((goto)
 196                           (let* ((succs (bb-succs bb))
 197                                  (dest (car succs)))
 198                             (bra (bb-label dest))
 199                             (add-todo dest)))
 200                          ((x==y x<y x>y)
 201                           (let* ((succs (bb-succs bb))
 202                                  (dest-true (car succs))
 203                                  (dest-false (cadr succs)))
 204
 205                             (define (compare flip adr)
 206                               (case (instr-id instr)
 207                                 ((x<y) (if flip (cpfsgt adr) (cpfslt adr)))
 208                                 ((x>y) (if flip (cpfslt adr) (cpfsgt adr)))
 209                                 (else (cpfseq adr)))
 210                               (bra (bb-label dest-false))
 211                               (bra (bb-label dest-true))
 212                               (add-todo dest-false)
 213                               (add-todo dest-true))
 214
 215                             (cond ((byte-lit? src1)
 216                                    (let ((n (byte-lit-val src1))
 217                                          (y (byte-cell-adr src2)))
 218                                      (if #f #;(and (or (= n 0) (= n 1) (= n #xff))
 219                                               (eq? (instr-id instr) 'x==y))
 220                                          (special-compare-eq-lit n x)
 221                                          (begin
 222                                            (movlw n)
 223                                            (compare #t y)))))
 224                                   ((byte-lit? src2)
 225                                    (let ((x (byte-cell-adr src1))
 226                                          (n (byte-lit-val src2)))
 227                                      (if #f #;(and (or (= n 0) (= n 1) (= n #xff))
 228                                               (eq? (instr-id instr) 'x==y))
 229                                          (special-compare-eq-lit n x) ;; TODO does not exist. the only way apart from cpfseq I see would be to load w, do a subtraction, then conditional branch, but would be larger and would take 1-2 cycles more
 230                                          (begin
 231                                            (movlw n)
 232                                            (compare #f x)))))
 233                                   (else
 234                                    (let ((x (byte-cell-adr src1))
 235                                          (y (byte-cell-adr src2)))
 236                                      (move-reg y WREG)
 237                                      (compare #f x))))))
 238                          (else
 239                           ;...
 240                           (emit (list (instr-id instr))))))))))
 241
 242         (if bb
 243             (begin
 244               (vector-set! bbs-vector label-num #f)
 245               (label (bb-label bb))
 246               (for-each dump-instr (reverse (bb-rev-instrs bb)))
 247               (for-each add-todo (bb-succs bb)))))))
 248
 249   (let ((prog-label (asm-make-label 'PROG)))
 250     (rcall prog-label)
 251     (sleep)
 252     (label prog-label))
 253
 254   (add-todo (vector-ref bbs-vector 0))
 255
 256   (let loop ()
 257     (if (null? todo)
 258         (reverse rev-code)
 259         (let ((bb (car todo)))
 260           (set! todo (cdr todo))
 261           (bb-linearize bb)
 262           (loop)))))
 263
 264
 265 (define (assembler-gen filename cfg)
 266
 267   (define (gen instr)
 268     (case (car instr)
 269       ((movlw)
 270        (movlw (cadr instr)))
 271       ((movwf)
 272        (movwf (cadr instr)))
 273       ((movfw)
 274        (movf (cadr instr) 'w))
 275       ((clrf)
 276        (clrf (cadr instr)))
 277       ((setf)
 278        (setf (cadr instr)))
 279       ((incf)
 280        (incf (cadr instr)))
 281       ((decf)
 282        (decf (cadr instr)))
 283       ((addwf)
 284        (addwf (cadr instr)))
 285       ((addwfc)
 286        (addwfc (cadr instr)))
 287       ((subwf)
 288        (subwf (cadr instr)))
 289       ((subwfb)
 290        (subwfb (cadr instr)))
 291       ((cpfseq)
 292        (cpfseq (cadr instr)))
 293       ((cpfslt)
 294        (cpfslt (cadr instr)))
 295       ((cpfsgt)
 296        (cpfsgt (cadr instr)))
 297       ((bra)
 298        (bra (cadr instr)))
 299       ((rcall)
 300        (rcall (cadr instr)))
 301       ((return)
 302        (return))
 303       ((label)
 304        (asm-listing
 305         (string-append (symbol->string (asm-label-id (cadr instr))) ":"))
 306        (asm-label (cadr instr)))
 307       ((sleep)
 308        (sleep))
 309       (else
 310 '       (error "unknown instruction" instr))))
 311
 312   (asm-begin! 0 #f)
 313
 314 ;  (pretty-print cfg)
 315
 316   (let ((code (linearize-and-cleanup cfg)))
 317 ;    (pretty-print code)
 318     (for-each gen code))
 319
 320   (asm-assemble)
 321
 322   '(display "------------------ GENERATED CODE\n")
 323
 324   (asm-display-listing (current-output-port))
 325
 326   (asm-write-hex-file (string-append filename ".hex")) ;; TODO move to main ?
 327
 328   (asm-end!))
 329
 330 (define (code-gen filename cfg)
 331   (allocate-registers cfg)
 332   (assembler-gen filename cfg)
 333 ;  (pretty-print cfg)
 334 ;  (pretty-print (reverse (bb-rev-instrs bb))) ;; TODO what ? there are no bbs here...
 335   )