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