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 (load "optim.scm")
  94
  95 (define expand-loads ;; ADDED
  96   (lambda (exprs)
  97     (map (lambda (e)
  98            (if (eq? (car e) 'load)
  99                (cons 'begin
 100                      (expand-loads (with-input-from-file (cadr e) read-all)))
 101                e))
 102          exprs)))
 103
 104 (define parse-file
 105   (lambda (filename)
 106     (let* ((library
 107             (with-input-from-file "library.scm" read-all))
 108            (toplevel-exprs
 109             (expand-loads (append library ;; ADDED (didn't have expand-loads)
 110                                   (with-input-from-file filename read-all))))
 111            (global-env
 112             (make-global-env))
 113            (parsed-prog
 114             (parse-top (cons 'begin toplevel-exprs) global-env)))
 115
 116       (for-each
 117        (lambda (node)
 118          (mark-needed-global-vars! global-env node))
 119        parsed-prog)
 120
 121       (extract-parts
 122        parsed-prog
 123        (lambda (defs after-defs)
 124
 125          (define make-seq-preparsed
 126            (lambda (exprs)
 127              (let ((r (make-seq #f exprs)))
 128                (for-each (lambda (x) (node-parent-set! x r)) exprs)
 129                r)))
 130
 131          (define make-call-preparsed
 132            (lambda (exprs)
 133              (let ((r (make-call #f exprs)))
 134                (for-each (lambda (x) (node-parent-set! x r)) exprs)
 135                r)))
 136
 137          (if (var-needed?
 138               (env-lookup global-env '#%readyq))
 139              (make-seq-preparsed
 140               (list (make-seq-preparsed defs)
 141                     (make-call-preparsed
 142                      (list (parse 'value '#%start-first-process global-env)
 143                            (let* ((pattern
 144                                    '())
 145                                   (ids
 146                                    (extract-ids pattern))
 147                                   (r
 148                                    (make-prc #f '() #f (has-rest-param? pattern) #f))
 149                                   (new-env
 150                                    (env-extend global-env ids r))
 151                                   (body
 152                                    (make-seq-preparsed after-defs)))
 153                              (prc-params-set!
 154                               r
 155                               (map (lambda (id) (env-lookup new-env id))
 156                                    ids))
 157                              (node-children-set! r (list body))
 158                              (node-parent-set! body r)
 159                              r)))
 160                     (parse 'value
 161                            '(#%exit)
 162                            global-env)))
 163              (make-seq-preparsed
 164               (append defs
 165                       after-defs
 166                       (list (parse 'value
 167                                    '(#%halt)
 168                                    global-env))))))))))
 169
 170 (define extract-parts
 171   (lambda (lst cont)
 172     (if (or (null? lst)
 173             (not (def? (car lst))))
 174         (cont '() lst)
 175         (extract-parts
 176          (cdr lst)
 177          (lambda (d ad)
 178            (cont (cons (car lst) d) ad))))))
 179
 180 ;------------------------------------------------------------------------------
 181
 182 (load "asm.scm")
 183
 184 ;------------------------------------------------------------------------------
 185
 186 (load "encode.scm")
 187
 188 (define assemble
 189   (lambda (code hex-filename)
 190     (let loop1 ((lst code)
 191                 (constants (predef-constants))
 192                 (globals (predef-globals))
 193                 (labels (list)))
 194       (if (pair? lst)
 195
 196           (let ((instr (car lst)))
 197             (cond ((number? instr)
 198                    (loop1 (cdr lst)
 199                           constants
 200                           globals
 201                           (cons (cons instr (asm-make-label 'label))
 202                                 labels)))
 203                   ((eq? (car instr) 'push-constant)
 204                    (add-constant (cadr instr)
 205                                  constants
 206                                  #t
 207                                  (lambda (new-constants)
 208                                    (loop1 (cdr lst)
 209                                           new-constants
 210                                           globals
 211                                           labels))))
 212                   ((memq (car instr) '(push-global set-global))
 213                    (add-global (cadr instr)
 214                                globals
 215                                (lambda (new-globals)
 216                                  (loop1 (cdr lst)
 217                                         constants
 218                                         new-globals
 219                                         labels))))
 220                   (else
 221                    (loop1 (cdr lst)
 222                           constants
 223                           globals
 224                           labels))))
 225
 226           (let ((constants (sort-constants constants)))
 227
 228             (define (label-instr label opcode)
 229               (asm-at-assembly
 230                (lambda (self)
 231                  3) ;; TODO BARF was 2, maybe was length ? seems to be fixed
 232                (lambda (self)
 233                  (let ((pos (- (asm-label-pos label) code-start)))
 234                    ;; (asm-8 (+ (quotient pos 256) opcode))
 235                    ;; TODO do we mess up any offsets ? FOOBAR
 236                    (asm-8 opcode)
 237                    (asm-8 (quotient pos 256))
 238                    (asm-8 (modulo pos 256))))))
 239
 240             (define (push-constant n)
 241               (if (<= n 31)
 242                   (asm-8 (+ #x00 n))
 243                   (begin
 244                     (asm-8 #xfc)
 245                     (asm-8 (quotient n 256))
 246                     (asm-8 (modulo n 256))))) ;; TODO with 13-bit objects, we need 2 bytes, maybe limit to 12, so we could use a byte and a half, but we'd need to use an opcode with only 4 bits, maybe the call/jump stuff can be combined ? FOOBAR
 247
 248             (define (push-stack n)
 249               (if (> n 31)
 250                   (compiler-error "stack is too deep")
 251                   (asm-8 (+ #x20 n))))
 252
 253             (define (push-global n)
 254               (asm-8 (+ #x40 n)) ;; TODO maybe do the same as for csts, have a push-long-global to have more ?
 255               ;; (if (> n 15)
 256               ;;     (compiler-error "too many global variables")
 257               ;;     (asm-8 (+ #x40 n)))
 258               ) ;; TODO actually inline most, or put as csts
 259
 260             (define (set-global n)
 261               (asm-8 (+ #x50 n))
 262               ;; (if (> n 15) ;; ADDED prevented the stack from compiling
 263               ;;     (compiler-error "too many global variables")
 264               ;;     (asm-8 (+ #x50 n)))
 265               )
 266
 267             (define (call n)
 268               (if (> n 15)
 269                   (compiler-error "call has too many arguments")
 270                   (asm-8 (+ #x60 n))))
 271
 272             (define (jump n)
 273               (if (> n 15)
 274                   (compiler-error "call has too many arguments")
 275                   (asm-8 (+ #x70 n))))
 276
 277             (define (call-toplevel label) ;; TODO use 8-bit opcodes for these
 278               (label-instr label #x80))
 279
 280             (define (jump-toplevel label)
 281               (label-instr label #x90))
 282
 283             (define (goto label)
 284               (label-instr label #xa0))
 285
 286             (define (goto-if-false label)
 287               (label-instr label #xb0))
 288
 289             (define (closure label)
 290               (label-instr label #xc0)) ;; FOOBAR change here ?
 291
 292             (define (prim n)
 293               (asm-8 (+ #xd0 n)))
 294
 295             (define (prim.number?)        (prim 0))
 296             (define (prim.+)              (prim 1))
 297             (define (prim.-)              (prim 2))
 298             (define (prim.*)              (prim 3))
 299             (define (prim.quotient)       (prim 4))
 300             (define (prim.remainder)      (prim 5))
 301             (define (prim.neg)            (prim 6))
 302             (define (prim.=)              (prim 7))
 303             (define (prim.<)              (prim 8))
 304             (define (prim.ior)            (prim 9))
 305             (define (prim.>)              (prim 10))
 306             (define (prim.xor)            (prim 11))
 307             (define (prim.pair?)          (prim 12))
 308             (define (prim.cons)           (prim 13))
 309             (define (prim.car)            (prim 14))
 310             (define (prim.cdr)            (prim 15))
 311             (define (prim.set-car!)       (prim 16))
 312             (define (prim.set-cdr!)       (prim 17))
 313             (define (prim.null?)          (prim 18))
 314             (define (prim.eq?)            (prim 19))
 315             (define (prim.not)            (prim 20))
 316             (define (prim.get-cont)       (prim 21))
 317             (define (prim.graft-to-cont)  (prim 22))
 318             (define (prim.return-to-cont) (prim 23))
 319             (define (prim.halt)           (prim 24))
 320             (define (prim.symbol?)        (prim 25))
 321             (define (prim.string?)        (prim 26))
 322             (define (prim.string->list)   (prim 27))
 323             (define (prim.list->string)   (prim 28))
 324
 325             (define (prim.print)          (prim 32))
 326             (define (prim.clock)          (prim 33))
 327             (define (prim.motor)          (prim 34))
 328             (define (prim.led)            (prim 35))
 329             (define (prim.led2-color)     (prim 36))
 330             (define (prim.getchar-wait)   (prim 37))
 331             (define (prim.putchar)        (prim 38))
 332             (define (prim.beep)           (prim 39))
 333             (define (prim.adc)            (prim 40))
 334             (define (prim.dac)            (prim 41))
 335             (define (prim.sernum)         (prim 42)) ;; TODO necessary ?
 336
 337             (define (prim.shift)          (prim 45))
 338             (define (prim.pop)            (prim 46))
 339             (define (prim.return)         (prim 47))
 340
 341             (define big-endian? #f)
 342
 343             (asm-begin! code-start #f)
 344
 345             (asm-8 #xfb)
 346             (asm-8 #xd7)
 347             (asm-8 (length constants))
 348             (asm-8 0)
 349
 350             (pp (list constants: constants globals: globals)) ;; TODO debug
 351
 352             (for-each
 353              (lambda (x)
 354                (let* ((descr (cdr x))
 355                       (label (vector-ref descr 1))
 356                       (obj (car x)))
 357                  (asm-label label)
 358                  ;; see the vm source for a description of encodings
 359                  (cond ((and (integer? obj) (exact? obj))
 360                         (asm-8 0)
 361                         (asm-8 (bitwise-and (arithmetic-shift obj -16) 255))
 362                         (asm-8 (bitwise-and (arithmetic-shift obj -8) 255))
 363                         (asm-8 (bitwise-and obj 255)))
 364                        ((pair? obj)
 365                         (let ((obj-car (encode-constant (car obj) constants))
 366                               (obj-cdr (encode-constant (cdr obj) constants)))
 367                           (asm-8 (+ #x80 (arithmetic-shift obj-car -8)))
 368                           (asm-8 (bitwise-and obj-car #xff))
 369                           (asm-8 (+ 0 (arithmetic-shift obj-cdr -8)))
 370                           (asm-8 (bitwise-and obj-cdr #xff))))
 371                        ((symbol? obj)
 372                         (asm-8 #x80)
 373                         (asm-8 0)
 374                         (asm-8 #x20)
 375                         (asm-8 0))
 376                        ((string? obj)
 377                         (let ((obj-enc (encode-constant (vector-ref descr 3)
 378                                                         constants)))
 379                           (asm-8 (+ #x80 (arithmetic-shift obj-enc -8)))
 380                           (asm-8 (bitwise-and obj-enc #xff))
 381                           (asm-8 #x40)
 382                           (asm-8 0)))
 383                        ((vector? obj)
 384                         (let ((obj-enc (encode-constant (vector-ref descr 3)
 385                                                         constants)))
 386                           (asm-8 (+ #x80 (arithmetic-shift obj-enc -8)))
 387                           (asm-8 (bitwise-and obj-enc #xff))
 388                           (asm-8 #x60)
 389                           (asm-8 0)))
 390                        (else
 391                         (compiler-error "unknown object type" obj)))))
 392              constants)
 393
 394             (let loop2 ((lst code))
 395               (if (pair? lst)
 396                   (let ((instr (car lst)))
 397
 398                     (cond ((number? instr)
 399                            (let ((label (cdr (assq instr labels))))
 400                              (asm-label label)))
 401
 402                           ((eq? (car instr) 'entry)
 403                            (let ((np (cadr instr))
 404                                  (rest? (caddr instr)))
 405                              (asm-8 (if rest? (- np) np))))
 406
 407                           ((eq? (car instr) 'push-constant) ;; TODO FOOBAR 12 bits for constants now (actually, I don't think it matters here)
 408                            (let ((n (encode-constant (cadr instr) constants)))
 409                              (push-constant n)))
 410
 411                           ((eq? (car instr) 'push-stack)
 412                            (push-stack (cadr instr)))
 413
 414                           ((eq? (car instr) 'push-global)
 415                            (push-global (cdr (assq (cadr instr) globals))))
 416
 417                           ((eq? (car instr) 'set-global)
 418                            (set-global (cdr (assq (cadr instr) globals))))
 419
 420                           ((eq? (car instr) 'call)
 421                            (call (cadr instr)))
 422
 423                           ((eq? (car instr) 'jump)
 424                            (jump (cadr instr)))
 425
 426                           ((eq? (car instr) 'call-toplevel)
 427                            (let ((label (cdr (assq (cadr instr) labels))))
 428                              (call-toplevel label)))
 429
 430                           ((eq? (car instr) 'jump-toplevel)
 431                            (let ((label (cdr (assq (cadr instr) labels))))
 432                              (jump-toplevel label)))
 433
 434                           ((eq? (car instr) 'goto)
 435                            (let ((label (cdr (assq (cadr instr) labels))))
 436                              (goto label)))
 437
 438                           ((eq? (car instr) 'goto-if-false)
 439                            (let ((label (cdr (assq (cadr instr) labels))))
 440                              (goto-if-false label)))
 441
 442                           ((eq? (car instr) 'closure)
 443                            (let ((label (cdr (assq (cadr instr) labels))))
 444                              (closure label)))
 445
 446                           ((eq? (car instr) 'prim)
 447                            (case (cadr instr)
 448                              ((#%number?)        (prim.number?))
 449                              ((#%+)              (prim.+))
 450                              ((#%-)              (prim.-))
 451                              ((#%*)              (prim.*))
 452                              ((#%quotient)       (prim.quotient))
 453                              ((#%remainder)      (prim.remainder))
 454                              ((#%neg)            (prim.neg))
 455                              ((#%=)              (prim.=))
 456                              ((#%<)              (prim.<))
 457                              ((#%ior)            (prim.ior))
 458                              ((#%>)              (prim.>))
 459                              ((#%xor)            (prim.xor))
 460                              ((#%pair?)          (prim.pair?))
 461                              ((#%cons)           (prim.cons))
 462                              ((#%car)            (prim.car))
 463                              ((#%cdr)            (prim.cdr))
 464                              ((#%set-car!)       (prim.set-car!))
 465                              ((#%set-cdr!)       (prim.set-cdr!))
 466                              ((#%null?)          (prim.null?))
 467                              ((#%eq?)            (prim.eq?))
 468                              ((#%not)            (prim.not))
 469                              ((#%get-cont)       (prim.get-cont))
 470                              ((#%graft-to-cont)  (prim.graft-to-cont))
 471                              ((#%return-to-cont) (prim.return-to-cont))
 472                              ((#%halt)           (prim.halt))
 473                              ((#%symbol?)        (prim.symbol?))
 474                              ((#%string?)        (prim.string?))
 475                              ((#%string->list)   (prim.string->list))
 476                              ((#%list->string)   (prim.list->string))
 477
 478                              ((#%print)          (prim.print))
 479                              ((#%clock)          (prim.clock))
 480                              ((#%motor)          (prim.motor))
 481                              ((#%led)            (prim.led))
 482                              ((#%led2-color)     (prim.led2-color))
 483                              ((#%getchar-wait)   (prim.getchar-wait))
 484                              ((#%putchar)        (prim.putchar))
 485                              ((#%beep)           (prim.beep))
 486                              ((#%adc)            (prim.adc))
 487                              ((#%dac)            (prim.dac))
 488                              ((#%sernum)         (prim.sernum))
 489                              (else
 490                               (compiler-error "unknown primitive" (cadr instr)))))
 491
 492                           ((eq? (car instr) 'return)
 493                            (prim.return))
 494
 495                           ((eq? (car instr) 'pop)
 496                            (prim.pop))
 497
 498                           ((eq? (car instr) 'shift)
 499                            (prim.shift))
 500
 501                           (else
 502                            (compiler-error "unknown instruction" instr)))
 503
 504                     (loop2 (cdr lst)))))
 505
 506             (asm-assemble)
 507
 508             (asm-write-hex-file hex-filename)
 509
 510             (asm-end!))))))
 511
 512 (define execute
 513   (lambda (hex-filename)
 514 '
 515     (if #f
 516         (begin
 517           (shell-command "gcc -o picobit-vm picobit-vm.c")
 518           (shell-command (string-append "./picobit-vm " hex-filename)))
 519         (shell-command (string-append "./robot . 1 " hex-filename)))))
 520
 521 (define (sort-list l <?)
 522
 523   (define (mergesort l)
 524
 525     (define (merge l1 l2)
 526       (cond ((null? l1) l2)
 527             ((null? l2) l1)
 528             (else
 529              (let ((e1 (car l1)) (e2 (car l2)))
 530                (if (<? e1 e2)
 531                  (cons e1 (merge (cdr l1) l2))
 532                  (cons e2 (merge l1 (cdr l2))))))))
 533
 534     (define (split l)
 535       (if (or (null? l) (null? (cdr l)))
 536         l
 537         (cons (car l) (split (cddr l)))))
 538
 539     (if (or (null? l) (null? (cdr l)))
 540       l
 541       (let* ((l1 (mergesort (split l)))
 542              (l2 (mergesort (split (cdr l)))))
 543         (merge l1 l2))))
 544
 545   (mergesort l))
 546
 547 ;------------------------------------------------------------------------------
 548
 549 (define compile
 550   (lambda (filename)
 551     (let* ((node (parse-file filename))
 552            (hex-filename
 553             (string-append
 554              (path-strip-extension filename)
 555              ".hex")))
 556
 557 ;      (pp (node->expr node))
 558
 559       (let ((ctx (comp-none node (make-init-context))))
 560         (let ((prog (linearize (optimize-code (context-code ctx)))))
 561 ;         (pp (list code: prog env: (context-env ctx)))
 562           (assemble prog hex-filename)
 563           (execute hex-filename))))))
 564
 565
 566 (define main
 567   (lambda (filename)
 568     (compile filename)))
 569
 570 ;------------------------------------------------------------------------------
 571
 572 '
 573 (define (asm-write-hex-file filename)
 574   (with-output-to-file filename
 575     (lambda ()
 576
 577       (define (print-hex n)
 578         (display (string-ref "0123456789ABCDEF" n)))
 579
 580       (define (print-byte n)
 581         (display ", 0x")
 582         (print-hex (quotient n 16))
 583         (print-hex (modulo n 16)))
 584
 585       (define (print-line type addr bytes)
 586         (let ((n (length bytes))
 587               (addr-hi (quotient addr 256))
 588               (addr-lo (modulo addr 256)))
 589 ;          (display ":")
 590 ;          (print-byte n)
 591 ;          (print-byte addr-hi)
 592 ;          (print-byte addr-lo)
 593 ;          (print-byte type)
 594           (for-each print-byte bytes)
 595           (let ((sum
 596                  (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
 597 ;            (print-byte sum)
 598             (newline))))
 599
 600       (let loop ((lst (cdr asm-code-stream))
 601                  (pos asm-start-pos)
 602                  (rev-bytes '()))
 603         (if (not (null? lst))
 604           (let ((x (car lst)))
 605             (if (vector? x)
 606               (let ((kind (vector-ref x 0)))
 607                 (if (not (eq? kind 'LISTING))
 608                   (compiler-internal-error
 609                     "asm-write-hex-file, code stream not assembled"))
 610                 (loop (cdr lst)
 611                       pos
 612                       rev-bytes))
 613               (let ((new-pos
 614                      (+ pos 1))
 615                     (new-rev-bytes
 616                      (cons x
 617                            (if (= (modulo pos 8) 0)
 618                                (begin
 619                                  (print-line 0
 620                                              (- pos (length rev-bytes))
 621                                              (reverse rev-bytes))
 622                                  '())
 623                                rev-bytes))))
 624                 (loop (cdr lst)
 625                       new-pos
 626                       new-rev-bytes))))
 627           (begin
 628             (if (not (null? rev-bytes))
 629                 (print-line 0
 630                             (- pos (length rev-bytes))
 631                             (reverse rev-bytes)))
 632             (print-line 1 0 '())))))))