picobit.scm

   1 ; File: "picobit.scm", Time-stamp: <2006-05-08 16:04:37 feeley>
   2
   3 ; Copyright (C) 2006 by Marc Feeley, All Rights Reserved.
   4
   5 (define-macro (dummy)
   6   (proper-tail-calls-set! #f)
   7   #f)
   8 ;(dummy)
   9
  10 ;-----------------------------------------------------------------------------
  11
  12 (define compiler-error
  13   (lambda (msg . others)
  14     (display "*** ERROR -- ")
  15     (display msg)
  16     (for-each (lambda (x) (display " ") (write x)) others)
  17     (newline)
  18     (exit 1)))
  19
  20 ;-----------------------------------------------------------------------------
  21
  22 (define keep
  23   (lambda (keep? lst)
  24     (cond ((null? lst)       '())
  25           ((keep? (car lst)) (cons (car lst) (keep keep? (cdr lst))))
  26           (else              (keep keep? (cdr lst))))))
  27
  28 (define take
  29   (lambda (n lst)
  30     (if (> n 0)
  31         (cons (car lst) (take (- n 1) (cdr lst)))
  32         '())))
  33
  34 (define drop
  35   (lambda (n lst)
  36     (if (> n 0)
  37         (drop (- n 1) (cdr lst))
  38         lst)))
  39
  40 (define repeat
  41   (lambda (n x)
  42     (if (> n 0)
  43         (cons x (repeat (- n 1) x))
  44         '())))
  45
  46 (define pos-in-list
  47   (lambda (x lst)
  48     (let loop ((lst lst) (i 0))
  49       (cond ((not (pair? lst)) #f)
  50             ((eq? (car lst) x) i)
  51             (else              (loop (cdr lst) (+ i 1)))))))
  52
  53 (define every
  54   (lambda (pred? lst)
  55     (or (null? lst)
  56         (and (pred? (car lst))
  57              (every pred? (cdr lst))))))
  58
  59 ;-----------------------------------------------------------------------------
  60
  61 (load "node.scm")
  62
  63 ;-----------------------------------------------------------------------------
  64
  65 (load "env.scm")
  66
  67 ;-----------------------------------------------------------------------------
  68
  69 (load "parser.scm")
  70
  71 ;-----------------------------------------------------------------------------
  72
  73 (load "context.scm")
  74
  75 ;-----------------------------------------------------------------------------
  76
  77 (load "gen.scm")
  78
  79 ;-----------------------------------------------------------------------------
  80
  81 (load "comp.scm")
  82
  83 ;-----------------------------------------------------------------------------
  84
  85 (load "mutable.scm")
  86
  87 ;-----------------------------------------------------------------------------
  88
  89 (load "varset.scm")
  90
  91 ;------------------------------------------------------------------------------
  92
  93 (define code->vector
  94   (lambda (code)
  95     (let ((v (make-vector (+ (code-last-label code) 1))))
  96       (for-each
  97        (lambda (bb)
  98          (vector-set! v (bb-label bb) bb))
  99        (code-rev-bbs code))
 100       v)))
 101
 102 (define bbs->ref-counts
 103   (lambda (bbs)
 104     (let ((ref-counts (make-vector (vector-length bbs) 0)))
 105
 106       (define visit
 107         (lambda (label)
 108           (let ((ref-count (vector-ref ref-counts label)))
 109             (vector-set! ref-counts label (+ ref-count 1))
 110             (if (= ref-count 0)
 111                 (let* ((bb (vector-ref bbs label))
 112                        (rev-instrs (bb-rev-instrs bb)))
 113                   (for-each
 114                    (lambda (instr)
 115                      (let ((opcode (car instr)))
 116                        (cond ((eq? opcode 'goto)
 117                               (visit (cadr instr)))
 118                              ((eq? opcode 'goto-if-false)
 119                               (visit (cadr instr))
 120                               (visit (caddr instr)))
 121                              ((or (eq? opcode 'closure)
 122                                   (eq? opcode 'call-toplevel)
 123                                   (eq? opcode 'jump-toplevel))
 124                               (visit (cadr instr))))))
 125                    rev-instrs))))))
 126
 127       (visit 0)
 128
 129       ref-counts)))
 130
 131 (define resolve-toplevel-labels!
 132   (lambda (bbs)
 133     (let loop ((i 0))
 134       (if (< i (vector-length bbs))
 135           (let* ((bb (vector-ref bbs i))
 136                  (rev-instrs (bb-rev-instrs bb)))
 137             (bb-rev-instrs-set!
 138              bb
 139              (map (lambda (instr)
 140                     (let ((opcode (car instr)))
 141                       (cond ((eq? opcode 'call-toplevel)
 142                              (list opcode
 143                                    (prc-entry-label (cadr instr))))
 144                             ((eq? opcode 'jump-toplevel)
 145                              (list opcode
 146                                    (prc-entry-label (cadr instr))))
 147                             (else
 148                              instr))))
 149                   rev-instrs))
 150             (loop (+ i 1)))))))
 151
 152 (define tighten-jump-cascades!
 153   (lambda (bbs)
 154     (let ((ref-counts (bbs->ref-counts bbs)))
 155
 156       (define resolve
 157         (lambda (label)
 158           (let* ((bb (vector-ref bbs label))
 159                  (rev-instrs (bb-rev-instrs bb)))
 160             (and (or (null? (cdr rev-instrs))
 161                      (= (vector-ref ref-counts label) 1))
 162                  rev-instrs))))
 163
 164       (let loop1 ()
 165         (let loop2 ((i 0)
 166                     (changed? #f))
 167           (if (< i (vector-length bbs))
 168               (if (> (vector-ref ref-counts i) 0)
 169                   (let* ((bb (vector-ref bbs i))
 170                          (rev-instrs (bb-rev-instrs bb))
 171                          (jump (car rev-instrs))
 172                          (opcode (car jump)))
 173                     (cond ((eq? opcode 'goto)
 174                            (let* ((label (cadr jump))
 175                                   (jump-replacement (resolve label)))
 176                              (if jump-replacement
 177                                  (begin
 178                                    (vector-set!
 179                                     bbs
 180                                     i
 181                                     (make-bb (bb-label bb)
 182                                              (append jump-replacement
 183                                                      (cdr rev-instrs))))
 184                                    (loop2 (+ i 1)
 185                                           #t))
 186                                  (loop2 (+ i 1)
 187                                         changed?))))
 188                           ((eq? opcode 'goto-if-false)
 189                            (let* ((label-then (cadr jump))
 190                                   (label-else (caddr jump))
 191                                   (jump-then-replacement (resolve label-then))
 192                                   (jump-else-replacement (resolve label-else)))
 193                              (if (and jump-then-replacement
 194                                       (null? (cdr jump-then-replacement))
 195                                       jump-else-replacement
 196                                       (null? (cdr jump-else-replacement))
 197                                       (or (eq? (caar jump-then-replacement) 'goto)
 198                                           (eq? (caar jump-else-replacement) 'goto)))
 199                                  (begin
 200                                    (vector-set!
 201                                     bbs
 202                                     i
 203                                     (make-bb (bb-label bb)
 204                                              (cons (list 'goto-if-false
 205                                                          (if (eq? (caar jump-then-replacement) 'goto)
 206                                                              (cadar jump-then-replacement)
 207                                                              label-then)
 208                                                          (if (eq? (caar jump-else-replacement) 'goto)
 209                                                              (cadar jump-else-replacement)
 210                                                              label-else))
 211                                                    (cdr rev-instrs))))
 212                                    (loop2 (+ i 1)
 213                                           #t))
 214                                  (loop2 (+ i 1)
 215                                         changed?))))
 216                           (else
 217                            (loop2 (+ i 1)
 218                                   changed?))))
 219                   (loop2 (+ i 1)
 220                          changed?))
 221               (if changed?
 222                   (loop1))))))))
 223
 224 (define remove-useless-bbs!
 225   (lambda (bbs)
 226     (let ((ref-counts (bbs->ref-counts bbs)))
 227       (let loop1 ((label 0) (new-label 0))
 228         (if (< label (vector-length bbs))
 229             (if (> (vector-ref ref-counts label) 0)
 230                 (let ((bb (vector-ref bbs label)))
 231                   (vector-set!
 232                    bbs
 233                    label
 234                    (make-bb new-label (bb-rev-instrs bb)))
 235                   (loop1 (+ label 1) (+ new-label 1)))
 236                 (loop1 (+ label 1) new-label))
 237             (renumber-labels bbs ref-counts new-label))))))
 238
 239 (define renumber-labels
 240   (lambda (bbs ref-counts n)
 241     (let ((new-bbs (make-vector n)))
 242       (let loop2 ((label 0))
 243         (if (< label (vector-length bbs))
 244             (if (> (vector-ref ref-counts label) 0)
 245                 (let* ((bb (vector-ref bbs label))
 246                        (new-label (bb-label bb))
 247                        (rev-instrs (bb-rev-instrs bb)))
 248
 249                   (define fix
 250                     (lambda (instr)
 251
 252                       (define new-label
 253                         (lambda (label)
 254                           (bb-label (vector-ref bbs label))))
 255
 256                       (let ((opcode (car instr)))
 257                         (cond ((eq? opcode 'closure)
 258                                (list 'closure
 259                                      (new-label (cadr instr))))
 260                               ((eq? opcode 'call-toplevel)
 261                                (list 'call-toplevel
 262                                      (new-label (cadr instr))))
 263                               ((eq? opcode 'jump-toplevel)
 264                                (list 'jump-toplevel
 265                                      (new-label (cadr instr))))
 266                               ((eq? opcode 'goto)
 267                                (list 'goto
 268                                      (new-label (cadr instr))))
 269                               ((eq? opcode 'goto-if-false)
 270                                (list 'goto-if-false
 271                                      (new-label (cadr instr))
 272                                      (new-label (caddr instr))))
 273                               (else
 274                                instr)))))
 275
 276                   (vector-set!
 277                    new-bbs
 278                    new-label
 279                    (make-bb new-label (map fix rev-instrs)))
 280                   (loop2 (+ label 1)))
 281                 (loop2 (+ label 1)))
 282             new-bbs)))))
 283
 284 (define reorder!
 285   (lambda (bbs)
 286     (let* ((done (make-vector (vector-length bbs) #f)))
 287
 288       (define unscheduled?
 289         (lambda (label)
 290           (not (vector-ref done label))))
 291
 292       (define label-refs
 293         (lambda (instrs todo)
 294           (if (pair? instrs)
 295               (let* ((instr (car instrs))
 296                      (opcode (car instr)))
 297                 (cond ((or (eq? opcode 'closure)
 298                            (eq? opcode 'call-toplevel)
 299                            (eq? opcode 'jump-toplevel))
 300                        (label-refs (cdr instrs) (cons (cadr instr) todo)))
 301                       (else
 302                        (label-refs (cdr instrs) todo))))
 303               todo)))
 304
 305       (define schedule-here
 306         (lambda (label new-label todo cont)
 307           (let* ((bb (vector-ref bbs label))
 308                  (rev-instrs (bb-rev-instrs bb))
 309                  (jump (car rev-instrs))
 310                  (opcode (car jump))
 311                  (new-todo (label-refs rev-instrs todo)))
 312             (vector-set! bbs label (make-bb new-label rev-instrs))
 313             (vector-set! done label #t)
 314             (cond ((eq? opcode 'goto)
 315                    (let ((label (cadr jump)))
 316                      (if (unscheduled? label)
 317                          (schedule-here label
 318                                         (+ new-label 1)
 319                                         new-todo
 320                                         cont)
 321                          (cont (+ new-label 1)
 322                                new-todo))))
 323                   ((eq? opcode 'goto-if-false)
 324                    (let ((label-then (cadr jump))
 325                          (label-else (caddr jump)))
 326                      (cond ((unscheduled? label-else)
 327                             (schedule-here label-else
 328                                            (+ new-label 1)
 329                                            (cons label-then new-todo)
 330                                            cont))
 331                            ((unscheduled? label-then)
 332                             (schedule-here label-then
 333                                            (+ new-label 1)
 334                                            new-todo
 335                                            cont))
 336                            (else
 337                             (cont (+ new-label 1)
 338                                   new-todo)))))
 339                   (else
 340                    (cont (+ new-label 1)
 341                          new-todo))))))
 342
 343       (define schedule-somewhere
 344         (lambda (label new-label todo cont)
 345           (schedule-here label new-label todo cont)))
 346
 347       (define schedule-todo
 348         (lambda (new-label todo)
 349           (if (pair? todo)
 350               (let ((label (car todo)))
 351                 (if (unscheduled? label)
 352                     (schedule-somewhere label
 353                                         new-label
 354                                         (cdr todo)
 355                                         schedule-todo)
 356                     (schedule-todo new-label
 357                                    (cdr todo)))))))
 358
 359
 360       (schedule-here 0 0 '() schedule-todo)
 361
 362       (renumber-labels bbs
 363                        (make-vector (vector-length bbs) 1)
 364                        (vector-length bbs)))))
 365
 366 (define linearize
 367   (lambda (bbs)
 368     (let loop ((label (- (vector-length bbs) 1))
 369                (lst '()))
 370       (if (>= label 0)
 371           (let* ((bb (vector-ref bbs label))
 372                  (rev-instrs (bb-rev-instrs bb))
 373                  (jump (car rev-instrs))
 374                  (opcode (car jump)))
 375             (loop (- label 1)
 376                   (append
 377                    (list label)
 378                    (reverse
 379                     (cond ((eq? opcode 'goto)
 380                            (if (= (cadr jump) (+ label 1))
 381                                (cdr rev-instrs)
 382                                rev-instrs))
 383                           ((eq? opcode 'goto-if-false)
 384                            (cond ((= (caddr jump) (+ label 1))
 385                                   (cons (list 'goto-if-false (cadr jump))
 386                                         (cdr rev-instrs)))
 387                                  ((= (cadr jump) (+ label 1))
 388                                   (cons (list 'goto-if-not-false (caddr jump))
 389                                         (cdr rev-instrs)))
 390                                  (else
 391                                   (cons (list 'goto (caddr jump))
 392                                         (cons (list 'goto-if-false (cadr jump))
 393                                               (cdr rev-instrs))))))
 394                           (else
 395                            rev-instrs)))
 396                    lst)))
 397           lst))))
 398
 399 (define optimize-code
 400   (lambda (code)
 401     (let ((bbs (code->vector code)))
 402       (resolve-toplevel-labels! bbs)
 403       (tighten-jump-cascades! bbs)
 404       (let ((bbs (remove-useless-bbs! bbs)))
 405         (reorder! bbs)))))
 406
 407 (define expand-loads ;; ADDED
 408   (lambda (exprs)
 409     (map (lambda (e)
 410            (if (eq? (car e) 'load)
 411                (cons 'begin
 412                      (expand-loads (with-input-from-file (cadr e) read-all)))
 413                e))
 414          exprs)))
 415
 416 (define parse-file
 417   (lambda (filename)
 418     (let* ((library
 419             (with-input-from-file "library.scm" read-all))
 420            (toplevel-exprs
 421             (expand-loads (append library ;; ADDED (didn't have expand-loads)
 422                                   (with-input-from-file filename read-all))))
 423            (global-env
 424             (make-global-env))
 425            (parsed-prog
 426             (parse-top (cons 'begin toplevel-exprs) global-env)))
 427
 428       (for-each
 429        (lambda (node)
 430          (mark-needed-global-vars! global-env node))
 431        parsed-prog)
 432
 433       (extract-parts
 434        parsed-prog
 435        (lambda (defs after-defs)
 436
 437          (define make-seq-preparsed
 438            (lambda (exprs)
 439              (let ((r (make-seq #f exprs)))
 440                (for-each (lambda (x) (node-parent-set! x r)) exprs)
 441                r)))
 442
 443          (define make-call-preparsed
 444            (lambda (exprs)
 445              (let ((r (make-call #f exprs)))
 446                (for-each (lambda (x) (node-parent-set! x r)) exprs)
 447                r)))
 448
 449          (if (var-needed?
 450               (env-lookup global-env '#%readyq))
 451              (make-seq-preparsed
 452               (list (make-seq-preparsed defs)
 453                     (make-call-preparsed
 454                      (list (parse 'value '#%start-first-process global-env)
 455                            (let* ((pattern
 456                                    '())
 457                                   (ids
 458                                    (extract-ids pattern))
 459                                   (r
 460                                    (make-prc #f '() #f (has-rest-param? pattern) #f))
 461                                   (new-env
 462                                    (env-extend global-env ids r))
 463                                   (body
 464                                    (make-seq-preparsed after-defs)))
 465                              (prc-params-set!
 466                               r
 467                               (map (lambda (id) (env-lookup new-env id))
 468                                    ids))
 469                              (node-children-set! r (list body))
 470                              (node-parent-set! body r)
 471                              r)))
 472                     (parse 'value
 473                            '(#%exit)
 474                            global-env)))
 475              (make-seq-preparsed
 476               (append defs
 477                       after-defs
 478                       (list (parse 'value
 479                                    '(#%halt)
 480                                    global-env))))))))))
 481
 482 (define extract-parts
 483   (lambda (lst cont)
 484     (if (or (null? lst)
 485             (not (def? (car lst))))
 486         (cont '() lst)
 487         (extract-parts
 488          (cdr lst)
 489          (lambda (d ad)
 490            (cont (cons (car lst) d) ad))))))
 491
 492 ;------------------------------------------------------------------------------
 493
 494 (load "asm.scm")
 495
 496 ;------------------------------------------------------------------------------
 497
 498 (load "encode.scm")
 499
 500 (define assemble
 501   (lambda (code hex-filename)
 502     (let loop1 ((lst code)
 503                 (constants (predef-constants))
 504                 (globals (predef-globals))
 505                 (labels (list)))
 506       (if (pair? lst)
 507
 508           (let ((instr (car lst)))
 509             (cond ((number? instr)
 510                    (loop1 (cdr lst)
 511                           constants
 512                           globals
 513                           (cons (cons instr (asm-make-label 'label))
 514                                 labels)))
 515                   ((eq? (car instr) 'push-constant)
 516                    (add-constant (cadr instr)
 517                                  constants
 518                                  #t
 519                                  (lambda (new-constants)
 520                                    (loop1 (cdr lst)
 521                                           new-constants
 522                                           globals
 523                                           labels))))
 524                   ((memq (car instr) '(push-global set-global))
 525                    (add-global (cadr instr)
 526                                globals
 527                                (lambda (new-globals)
 528                                  (loop1 (cdr lst)
 529                                         constants
 530                                         new-globals
 531                                         labels))))
 532                   (else
 533                    (loop1 (cdr lst)
 534                           constants
 535                           globals
 536                           labels))))
 537
 538           (let ((constants (sort-constants constants)))
 539
 540             (define (label-instr label opcode)
 541               (asm-at-assembly
 542                (lambda (self)
 543                  2)
 544                (lambda (self)
 545                  (let ((pos (- (asm-label-pos label) code-start)))
 546                    (asm-8 (+ (quotient pos 256) opcode))
 547                    (asm-8 (modulo pos 256))))))
 548
 549             (define (push-constant n)
 550               (if (<= n 31)
 551                   (asm-8 (+ #x00 n))
 552                   (begin
 553                     (asm-8 #xfc)
 554                     (asm-8 n))))
 555
 556             (define (push-stack n)
 557               (if (> n 31)
 558                   (compiler-error "stack is too deep")
 559                   (asm-8 (+ #x20 n))))
 560
 561             (define (push-global n)
 562               (asm-8 (+ #x40 n)) ;; TODO we are actually limited to 16 constants, since we only have 4 bits to represent them
 563               ;; (if (> n 15) ;; ADDED prevented the stack from compiling
 564               ;;     (compiler-error "too many global variables")
 565               ;;     (asm-8 (+ #x40 n)))
 566               ) ;; TODO actually inline most, or put as csts
 567
 568             (define (set-global n)
 569               (asm-8 (+ #x50 n))
 570               ;; (if (> n 15) ;; ADDED prevented the stack from compiling
 571               ;;     (compiler-error "too many global variables")
 572               ;;     (asm-8 (+ #x50 n)))
 573               )
 574
 575             (define (call n)
 576               (if (> n 15)
 577                   (compiler-error "call has too many arguments")
 578                   (asm-8 (+ #x60 n))))
 579
 580             (define (jump n)
 581               (if (> n 15)
 582                   (compiler-error "call has too many arguments")
 583                   (asm-8 (+ #x70 n))))
 584
 585             (define (call-toplevel label)
 586               (label-instr label #x80))
 587
 588             (define (jump-toplevel label)
 589               (label-instr label #x90))
 590
 591             (define (goto label)
 592               (label-instr label #xa0))
 593
 594             (define (goto-if-false label)
 595               (label-instr label #xb0))
 596
 597             (define (closure label)
 598               (label-instr label #xc0))
 599
 600             (define (prim n)
 601               (asm-8 (+ #xd0 n)))
 602
 603             (define (prim.number?)        (prim 0))
 604             (define (prim.+)              (prim 1))
 605             (define (prim.-)              (prim 2))
 606             (define (prim.*)              (prim 3))
 607             (define (prim.quotient)       (prim 4))
 608             (define (prim.remainder)      (prim 5))
 609             (define (prim.neg)            (prim 6))
 610             (define (prim.=)              (prim 7))
 611             (define (prim.<)              (prim 8))
 612             (define (prim.ior)            (prim 9)) ;; ADDED
 613             (define (prim.>)              (prim 10))
 614             (define (prim.xor)            (prim 11)) ;; ADDED
 615             (define (prim.pair?)          (prim 12))
 616             (define (prim.cons)           (prim 13))
 617             (define (prim.car)            (prim 14))
 618             (define (prim.cdr)            (prim 15))
 619             (define (prim.set-car!)       (prim 16))
 620             (define (prim.set-cdr!)       (prim 17))
 621             (define (prim.null?)          (prim 18))
 622             (define (prim.eq?)            (prim 19))
 623             (define (prim.not)            (prim 20))
 624             (define (prim.get-cont)       (prim 21))
 625             (define (prim.graft-to-cont)  (prim 22))
 626             (define (prim.return-to-cont) (prim 23))
 627             (define (prim.halt)           (prim 24))
 628             (define (prim.symbol?)        (prim 25))
 629             (define (prim.string?)        (prim 26))
 630             (define (prim.string->list)   (prim 27))
 631             (define (prim.list->string)   (prim 28))
 632             (define (prim.set-fst!)       (prim 29)) ;; ADDED
 633             (define (prim.set-snd!)       (prim 30)) ;; ADDED
 634             (define (prim.set-trd!)       (prim 31)) ;; ADDED
 635
 636             (define (prim.print)          (prim 32))
 637             (define (prim.clock)          (prim 33))
 638             (define (prim.motor)          (prim 34))
 639             (define (prim.led)            (prim 35))
 640             (define (prim.getchar-wait)   (prim 36))
 641             (define (prim.putchar)        (prim 37))
 642             (define (prim.light)          (prim 38))
 643
 644             (define (prim.triplet?)       (prim 39)) ;; ADDED
 645             (define (prim.triplet)        (prim 40)) ;; ADDED
 646             (define (prim.fst)            (prim 41)) ;; ADDED
 647             (define (prim.snd)            (prim 42)) ;; ADDED
 648             (define (prim.trd)            (prim 43)) ;; ADDED
 649
 650             (define (prim.shift)          (prim 45))
 651             (define (prim.pop)            (prim 46))
 652             (define (prim.return)         (prim 47))
 653
 654             (define big-endian? #f)
 655
 656             (asm-begin! code-start #f)
 657
 658             (asm-8 #xfb)
 659             (asm-8 #xd7)
 660             (asm-8 (length constants)) ;; TODO maybe more constants ? that would mean more rom adress space, and less for ram, for now we are ok
 661             (asm-8 0)
 662
 663             (pp (list constants: constants globals: globals)) ;; TODO debug
 664
 665             (for-each
 666              (lambda (x)
 667                (let* ((descr (cdr x))
 668                       (label (vector-ref descr 1))
 669                       (obj (car x)))
 670                  (asm-label label)
 671                  (cond ((and (integer? obj) (exact? obj))
 672                         (asm-8 0)
 673                         (asm-8 (bitwise-and (arithmetic-shift obj -16) 255))
 674                         (asm-8 (bitwise-and (arithmetic-shift obj -8) 255))
 675                         (asm-8 (bitwise-and obj 255)))
 676                        ((pair? obj) ;; TODO this is ok no matter how many csts we have
 677                         (let ((obj-car (encode-constant (car obj) constants))
 678                               (obj-cdr (encode-constant (cdr obj) constants)))
 679                           ;; car and cdr are both represented in 12 bits, the
 680                           ;; center byte being shared between the 2
 681                           ;; TODO changed
 682                           (asm-8 2)
 683                           (asm-8
 684                            (arithmetic-shift (bitwise-and obj-car #xff0) -4))
 685                           (asm-8
 686                            (bitwise-ior (arithmetic-shift
 687                                          (bitwise-and obj-car #xf)
 688                                          4)
 689                                         (arithmetic-shift
 690                                          (bitwise-and obj-cdr #xf00)
 691                                          -8)))
 692                           (asm-8 (bitwise-and obj-cdr #xff))))
 693                        ((symbol? obj)
 694                         (asm-8 3)
 695                         (asm-8 0)
 696                         (asm-8 0)
 697                         (asm-8 0))
 698                        ((string? obj)
 699                         (let ((obj-enc (encode-constant (vector-ref descr 3)
 700                                                         constants)))
 701                           (asm-8 4) ;; TODO changed
 702                           (asm-8 (arithmetic-shift (bitwise-and obj-enc #xff0)
 703                                                    -4))
 704                           (asm-8 (arithmetic-shift (bitwise-and obj-enc #xf)
 705                                                    4))
 706                           (asm-8 0)))
 707                        ((vector? obj)
 708                         (let ((obj-enc (encode-constant (vector-ref descr 3)
 709                                                         constants)))
 710                           (asm-8 5) ;; TODO changed, and factor code
 711                           (asm-8 (arithmetic-shift (bitwise-and obj-enc #xff0)
 712                                                    -4))
 713                           (asm-8 (arithmetic-shift (bitwise-and obj-enc #xf)
 714                                                    4))
 715                           (asm-8 0)))
 716                        (else
 717                         (compiler-error "unknown object type" obj)))))
 718              constants)
 719
 720             (let loop2 ((lst code))
 721               (if (pair? lst)
 722                   (let ((instr (car lst)))
 723
 724                     (cond ((number? instr)
 725                            (let ((label (cdr (assq instr labels))))
 726                              (asm-label label)))
 727
 728                           ((eq? (car instr) 'entry)
 729                            (let ((np (cadr instr))
 730                                  (rest? (caddr instr)))
 731                              (asm-8 (if rest? (- np) np))))
 732
 733                           ((eq? (car instr) 'push-constant) ;; TODO FOOBAR 12 bits for constants now
 734                            (let ((n (encode-constant (cadr instr) constants)))
 735                              (push-constant n)))
 736
 737                           ((eq? (car instr) 'push-stack)
 738                            (push-stack (cadr instr)))
 739
 740                           ((eq? (car instr) 'push-global)
 741                            (push-global (cdr (assq (cadr instr) globals))))
 742
 743                           ((eq? (car instr) 'set-global)
 744                            (set-global (cdr (assq (cadr instr) globals))))
 745
 746                           ((eq? (car instr) 'call)
 747                            (call (cadr instr)))
 748
 749                           ((eq? (car instr) 'jump)
 750                            (jump (cadr instr)))
 751
 752                           ((eq? (car instr) 'call-toplevel)
 753                            (let ((label (cdr (assq (cadr instr) labels))))
 754                              (call-toplevel label)))
 755
 756                           ((eq? (car instr) 'jump-toplevel)
 757                            (let ((label (cdr (assq (cadr instr) labels))))
 758                              (jump-toplevel label)))
 759
 760                           ((eq? (car instr) 'goto)
 761                            (let ((label (cdr (assq (cadr instr) labels))))
 762                              (goto label)))
 763
 764                           ((eq? (car instr) 'goto-if-false)
 765                            (let ((label (cdr (assq (cadr instr) labels))))
 766                              (goto-if-false label)))
 767
 768                           ((eq? (car instr) 'closure)
 769                            (let ((label (cdr (assq (cadr instr) labels))))
 770                              (closure label)))
 771
 772                           ((eq? (car instr) 'prim)
 773                            (case (cadr instr)
 774                              ((#%number?)        (prim.number?))
 775                              ((#%+)              (prim.+))
 776                              ((#%-)              (prim.-))
 777                              ((#%*)              (prim.*))
 778                              ((#%quotient)       (prim.quotient))
 779                              ((#%remainder)      (prim.remainder))
 780                              ((#%neg)            (prim.neg))
 781                              ((#%=)              (prim.=))
 782                              ((#%<)              (prim.<))
 783                              ((#%ior)            (prim.ior)) ;; ADDED
 784                              ((#%>)              (prim.>))
 785                              ((#%xor)            (prim.xor)) ;; ADDED
 786                              ((#%pair?)          (prim.pair?))
 787                              ((#%cons)           (prim.cons))
 788                              ((#%car)            (prim.car))
 789                              ((#%cdr)            (prim.cdr))
 790                              ((#%set-car!)       (prim.set-car!))
 791                              ((#%set-cdr!)       (prim.set-cdr!))
 792                              ((#%null?)          (prim.null?))
 793                              ((#%eq?)            (prim.eq?))
 794                              ((#%not)            (prim.not))
 795                              ((#%get-cont)       (prim.get-cont))
 796                              ((#%graft-to-cont)  (prim.graft-to-cont))
 797                              ((#%return-to-cont) (prim.return-to-cont))
 798                              ((#%halt)           (prim.halt))
 799                              ((#%symbol?)        (prim.symbol?))
 800                              ((#%string?)        (prim.string?))
 801                              ((#%string->list)   (prim.string->list))
 802                              ((#%list->string)   (prim.list->string))
 803                              ((#%set-fst!)       (prim.set-fst!)) ;; ADDED
 804                              ((#%set-snd!)       (prim.set-snd!)) ;; ADDED
 805                              ((#%set-trd!)       (prim.set-trd!)) ;; ADDED
 806
 807                              ((#%print)          (prim.print))
 808                              ((#%clock)          (prim.clock))
 809                              ((#%motor)          (prim.motor))
 810                              ((#%led)            (prim.led))
 811                              ((#%getchar-wait)   (prim.getchar-wait))
 812                              ((#%putchar)        (prim.putchar))
 813                              ((#%light)          (prim.light))
 814
 815                              ((#%triplet?)       (prim.triplet?)) ;; ADDED
 816                              ((#%triplet)        (prim.triplet)) ;; ADDED
 817                              ((#%fst)            (prim.fst)) ;; ADDED
 818                              ((#%snd)            (prim.snd)) ;; ADDED
 819                              ((#%trd)            (prim.trd)) ;; ADDED
 820                              (else
 821                               (compiler-error "unknown primitive" (cadr instr)))))
 822
 823                           ((eq? (car instr) 'return)
 824                            (prim.return))
 825
 826                           ((eq? (car instr) 'pop)
 827                            (prim.pop))
 828
 829                           ((eq? (car instr) 'shift)
 830                            (prim.shift))
 831
 832                           (else
 833                            (compiler-error "unknown instruction" instr)))
 834
 835                     (loop2 (cdr lst)))))
 836
 837             (asm-assemble)
 838
 839             (asm-write-hex-file hex-filename)
 840
 841             (asm-end!))))))
 842
 843 (define execute
 844   (lambda (hex-filename)
 845 '
 846     (if #f
 847         (begin
 848           (shell-command "gcc -o picobit-vm picobit-vm.c")
 849           (shell-command (string-append "./picobit-vm " hex-filename)))
 850         (shell-command (string-append "./robot . 1 " hex-filename)))))
 851
 852 (define (sort-list l <?)
 853
 854   (define (mergesort l)
 855
 856     (define (merge l1 l2)
 857       (cond ((null? l1) l2)
 858             ((null? l2) l1)
 859             (else
 860              (let ((e1 (car l1)) (e2 (car l2)))
 861                (if (<? e1 e2)
 862                  (cons e1 (merge (cdr l1) l2))
 863                  (cons e2 (merge l1 (cdr l2))))))))
 864
 865     (define (split l)
 866       (if (or (null? l) (null? (cdr l)))
 867         l
 868         (cons (car l) (split (cddr l)))))
 869
 870     (if (or (null? l) (null? (cdr l)))
 871       l
 872       (let* ((l1 (mergesort (split l)))
 873              (l2 (mergesort (split (cdr l)))))
 874         (merge l1 l2))))
 875
 876   (mergesort l))
 877
 878 ;------------------------------------------------------------------------------
 879
 880 (define compile
 881   (lambda (filename)
 882     (let* ((node (parse-file filename))
 883            (hex-filename
 884             (string-append
 885              (path-strip-extension filename)
 886              ".hex")))
 887
 888 ;      (pp (node->expr node))
 889
 890       (let ((ctx (comp-none node (make-init-context))))
 891         (let ((prog (linearize (optimize-code (context-code ctx)))))
 892 ;         (pp (list code: prog env: (context-env ctx)))
 893           (assemble prog hex-filename)
 894           (execute hex-filename))))))
 895
 896
 897 (define main
 898   (lambda (filename)
 899     (compile filename)))
 900
 901 ;------------------------------------------------------------------------------
 902
 903 '
 904 (define (asm-write-hex-file filename)
 905   (with-output-to-file filename
 906     (lambda ()
 907
 908       (define (print-hex n)
 909         (display (string-ref "0123456789ABCDEF" n)))
 910
 911       (define (print-byte n)
 912         (display ", 0x")
 913         (print-hex (quotient n 16))
 914         (print-hex (modulo n 16)))
 915
 916       (define (print-line type addr bytes)
 917         (let ((n (length bytes))
 918               (addr-hi (quotient addr 256))
 919               (addr-lo (modulo addr 256)))
 920 ;          (display ":")
 921 ;          (print-byte n)
 922 ;          (print-byte addr-hi)
 923 ;          (print-byte addr-lo)
 924 ;          (print-byte type)
 925           (for-each print-byte bytes)
 926           (let ((sum
 927                  (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
 928 ;            (print-byte sum)
 929             (newline))))
 930
 931       (let loop ((lst (cdr asm-code-stream))
 932                  (pos asm-start-pos)
 933                  (rev-bytes '()))
 934         (if (not (null? lst))
 935           (let ((x (car lst)))
 936             (if (vector? x)
 937               (let ((kind (vector-ref x 0)))
 938                 (if (not (eq? kind 'LISTING))
 939                   (compiler-internal-error
 940                     "asm-write-hex-file, code stream not assembled"))
 941                 (loop (cdr lst)
 942                       pos
 943                       rev-bytes))
 944               (let ((new-pos
 945                      (+ pos 1))
 946                     (new-rev-bytes
 947                      (cons x
 948                            (if (= (modulo pos 8) 0)
 949                                (begin
 950                                  (print-line 0
 951                                              (- pos (length rev-bytes))
 952                                              (reverse rev-bytes))
 953                                  '())
 954                                rev-bytes))))
 955                 (loop (cdr lst)
 956                       new-pos
 957                       new-rev-bytes))))
 958           (begin
 959             (if (not (null? rev-bytes))
 960                 (print-line 0
 961                             (- pos (length rev-bytes))
 962                             (reverse rev-bytes)))
 963             (print-line 1 0 '())))))))