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 ;; Syntax-tree node representation.
  62
  63 (define-type node
  64   extender: define-type-of-node
  65   parent
  66   children
  67 )
  68
  69 (define-type-of-node cst
  70   val
  71 )
  72
  73 (define-type-of-node ref
  74   var
  75 )
  76
  77 (define-type-of-node def
  78   var
  79 )
  80
  81 (define-type-of-node set
  82   var
  83 )
  84
  85 (define-type-of-node if
  86 )
  87
  88 (define-type-of-node prc
  89   params
  90   rest?
  91   entry-label
  92 )
  93
  94 (define-type-of-node call
  95 )
  96
  97 (define-type-of-node seq
  98 )
  99
 100 (define-type-of-node fix
 101   vars
 102 )
 103
 104 (define node->expr
 105   (lambda (node)
 106     (cond ((cst? node)
 107            (let ((val (cst-val node)))
 108              (if (self-eval? val)
 109                  val
 110                  (list 'quote val))))
 111           ((ref? node)
 112            (var-id (ref-var node)))
 113           ((def? node)
 114            (list 'define
 115                  (var-id (def-var node))
 116                  (node->expr (child1 node))))
 117           ((set? node)
 118            (list 'set!
 119                  (var-id (set-var node))
 120                  (node->expr (child1 node))))
 121           ((if? node)
 122            (list 'if
 123                  (node->expr (child1 node))
 124                  (node->expr (child2 node))
 125                  (node->expr (child3 node))))
 126           ((prc? node)
 127            (if (seq? (child1 node))
 128                (cons 'lambda
 129                      (cons (build-pattern (prc-params node) (prc-rest? node))
 130                            (nodes->exprs (node-children (child1 node)))))
 131                (list 'lambda
 132                      (build-pattern (prc-params node) (prc-rest? node))
 133                      (node->expr (child1 node)))))
 134           ((call? node)
 135            (map node->expr (node-children node)))
 136           ((seq? node)
 137            (let ((children (node-children node)))
 138              (cond ((null? children)
 139                     '(void))
 140                    ((null? (cdr children))
 141                     (node->expr (car children)))
 142                    (else
 143                     (cons 'begin
 144                           (nodes->exprs children))))))
 145           ((fix? node)
 146            (let ((children (node-children node)))
 147              (list 'letrec
 148                    (map (lambda (var val)
 149                           (list (var-id var)
 150                                 (node->expr val)))
 151                         (fix-vars node)
 152                         (take (- (length children) 1) children))
 153                    (node->expr (list-ref children (- (length children) 1))))))
 154           (else
 155            (compiler-error "unknown expression type" node)))))
 156
 157 (define nodes->exprs
 158   (lambda (nodes)
 159     (if (null? nodes)
 160         '()
 161         (if (seq? (car nodes))
 162             (append (nodes->exprs (node-children (car nodes)))
 163                     (nodes->exprs (cdr nodes)))
 164             (cons (node->expr (car nodes))
 165                   (nodes->exprs (cdr nodes)))))))
 166
 167 (define build-pattern
 168   (lambda (params rest?)
 169     (cond ((null? params)
 170            '())
 171           ((null? (cdr params))
 172            (if rest?
 173                (var-id (car params))
 174                (list (var-id (car params)))))
 175           (else
 176            (cons (var-id (car params))
 177                  (build-pattern (cdr params) rest?))))))
 178
 179 ;-----------------------------------------------------------------------------
 180
 181 ;; Environment representation.
 182
 183 (define-type var
 184   id
 185   global?
 186   refs
 187   sets
 188   defs
 189   needed?
 190   primitive
 191 )
 192
 193 (define-type primitive
 194   nargs
 195   inliner
 196   unspecified-result?
 197 )
 198
 199 (define-type renaming
 200   renamings
 201 )
 202
 203 (define make-global-env
 204   (lambda ()
 205     (list (make-var '#%number? #t '() '() '() #f (make-primitive 1 #f #f))
 206           (make-var '#%+ #t '() '() '() #f (make-primitive 2 #f #f))
 207           (make-var '#%- #t '() '() '() #f (make-primitive 2 #f #f))
 208           (make-var '#%* #t '() '() '() #f (make-primitive 2 #f #f))
 209           (make-var '#%quotient #t '() '() '() #f (make-primitive 2 #f #f))
 210           (make-var '#%remainder #t '() '() '() #f (make-primitive 2 #f #f))
 211           (make-var '#%neg #t '() '() '() #f (make-primitive 1 #f #f))
 212           (make-var '#%= #t '() '() '() #f (make-primitive 2 #f #f))
 213           (make-var '#%< #t '() '() '() #f (make-primitive 2 #f #f))
 214           (make-var '#%ior #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED
 215           (make-var '#%> #t '() '() '() #f (make-primitive 2 #f #f))
 216           (make-var '#%xor #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED
 217           (make-var '#%pair? #t '() '() '() #f (make-primitive 1 #f #f))
 218           (make-var '#%cons #t '() '() '() #f (make-primitive 2 #f #f))
 219           (make-var '#%car #t '() '() '() #f (make-primitive 1 #f #f))
 220           (make-var '#%cdr #t '() '() '() #f (make-primitive 1 #f #f))
 221           (make-var '#%set-car! #t '() '() '() #f (make-primitive 2 #f #t))
 222           (make-var '#%set-cdr! #t '() '() '() #f (make-primitive 2 #f #t))
 223           (make-var '#%null? #t '() '() '() #f (make-primitive 1 #f #f))
 224           (make-var '#%eq? #t '() '() '() #f (make-primitive 2 #f #f))
 225           (make-var '#%not #t '() '() '() #f (make-primitive 1 #f #f))
 226           (make-var '#%get-cont #t '() '() '() #f (make-primitive 0 #f #f))
 227           (make-var '#%graft-to-cont #t '() '() '() #f (make-primitive 2 #f #f))
 228           (make-var '#%return-to-cont #t '() '() '() #f (make-primitive 2 #f #f))
 229           (make-var '#%halt #t '() '() '() #f (make-primitive 0 #f #t))
 230           (make-var '#%symbol? #t '() '() '() #f (make-primitive 1 #f #f))
 231           (make-var '#%string? #t '() '() '() #f (make-primitive 1 #f #f))
 232           (make-var '#%string->list #t '() '() '() #f (make-primitive 1 #f #f))
 233           (make-var '#%list->string #t '() '() '() #f (make-primitive 1 #f #f))
 234
 235           (make-var '#%make-u8vector #t '() '() '() #f (make-primitive 1 #f #f)) ;; ADDED
 236           (make-var '#%u8vector-ref #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED
 237           (make-var '#%u8vector-set! #t '() '() '() #f (make-primitive 3 #f #f)) ;; ADDED
 238
 239           (make-var '#%print #t '() '() '() #f (make-primitive 1 #f #t))
 240           (make-var '#%clock #t '() '() '() #f (make-primitive 0 #f #f))
 241           (make-var '#%motor #t '() '() '() #f (make-primitive 2 #f #t))
 242           (make-var '#%led #t '() '() '() #f (make-primitive 3 #f #t))
 243           (make-var '#%led2-color #t '() '() '() #f (make-primitive 1 #f #t))
 244           (make-var '#%getchar-wait #t '() '() '() #f (make-primitive 2 #f #f))
 245           (make-var '#%putchar #t '() '() '() #f (make-primitive 2 #f #t))
 246           (make-var '#%beep #t '() '() '() #f (make-primitive 2 #f #f))
 247           (make-var '#%adc #t '() '() '() #f (make-primitive 1 #f #f))
 248           (make-var '#%u8vector? #t '() '() '() #f (make-primitive 1 #f #f)) ;; ADDED, was dac
 249           (make-var '#%sernum #t '() '() '() #f (make-primitive 0 #f #f))
 250           (make-var '#%u8vector-length #t '() '() '() #f (make-primitive 1 #f #f)) ;; ADDED
 251
 252           (make-var '#%readyq #t '() '() '() #f #f)
 253
 254           )))
 255
 256 (define env-lookup
 257   (lambda (env id)
 258     (let loop ((lst env) (id id))
 259       (let ((b (car lst)))
 260         (cond ((and (renaming? b)
 261                     (assq id (renaming-renamings b)))
 262                =>
 263                (lambda (x)
 264                  (loop (cdr lst) (cadr x))))
 265               ((and (var? b)
 266                     (eq? (var-id b) id))
 267                b)
 268               ((null? (cdr lst))
 269                (let ((x (make-var id #t '() '() '() #f #f)))
 270                  (set-cdr! lst (cons x '()))
 271                  x))
 272               (else
 273                (loop (cdr lst) id)))))))
 274
 275 (define env-extend
 276   (lambda (env ids def)
 277     (append (map (lambda (id)
 278                    (make-var id #f '() '() (list def) #f #f))
 279                  ids)
 280             env)))
 281
 282 (define env-extend-renamings
 283   (lambda (env renamings)
 284     (cons (make-renaming renamings) env)))
 285
 286 ;-----------------------------------------------------------------------------
 287
 288 ;; Parsing.
 289
 290 (define parse-program
 291   (lambda (expr env)
 292     (let ((x (parse-top expr env)))
 293       (cond ((null? x)
 294              (parse 'value #f env))
 295             ((null? (cdr x))
 296              (car x))
 297             (else
 298              (let ((r (make-seq #f x)))
 299                (for-each (lambda (y) (node-parent-set! y r)) x)
 300                r))))))
 301
 302 (define parse-top
 303   (lambda (expr env)
 304     (cond ((and (pair? expr)
 305                 (eq? (car expr) 'begin))
 306            (parse-top-list (cdr expr) env))
 307           ((and (pair? expr)
 308                 (eq? (car expr) 'hide))
 309            (parse-top-hide (cadr expr)  (cddr expr) env))
 310           ((and (pair? expr)
 311                 (eq? (car expr) 'rename))
 312            (parse-top-rename (cadr expr)  (cddr expr) env))
 313           ((and (pair? expr)
 314                 (eq? (car expr) 'define))
 315            (let ((var
 316                   (if (pair? (cadr expr))
 317                       (car (cadr expr))
 318                       (cadr expr)))
 319                  (val
 320                   (if (pair? (cadr expr))
 321                       (cons 'lambda (cons (cdr (cadr expr)) (cddr expr)))
 322                       (caddr expr))))
 323              (let* ((var2 (env-lookup env var))
 324                     (val2 (parse 'value val env))
 325                     (r (make-def #f (list val2) var2)))
 326                (node-parent-set! val2 r)
 327                (var-defs-set! var2 (cons r (var-defs var2)))
 328                (list r))))
 329           (else
 330            (list (parse 'value expr env))))))
 331
 332 (define parse-top-list
 333   (lambda (lst env)
 334     (if (pair? lst)
 335         (append (parse-top (car lst) env)
 336                 (parse-top-list (cdr lst) env))
 337         '())))
 338
 339 (define parse-top-hide
 340   (lambda (renamings body env)
 341     (append
 342      (parse-top-list body
 343                      (env-extend-renamings env renamings))
 344 #|
 345      (parse-top-list
 346       (map (lambda (x) (list 'define (car x) (cadr x))) renamings)
 347       env)
 348 |#
 349 )))
 350
 351 (define parse-top-rename
 352   (lambda (renamings body env)
 353     (parse-top-list body
 354                     (env-extend-renamings env renamings))))
 355
 356 (define parse
 357   (lambda (use expr env)
 358     (cond ((self-eval? expr)
 359            (make-cst #f '() expr))
 360           ((symbol? expr)
 361            (let* ((var (env-lookup env expr))
 362                   (r (make-ref #f '() var)))
 363              (var-refs-set! var (cons r (var-refs var)))
 364              r))
 365           ((and (pair? expr) ;; ADDED, when we have a true macroexpander, get rid
 366                 (eq? (car expr) 'cond))
 367            (parse use
 368                   `(if ,(caadr expr)
 369                        (begin ,@(cdadr expr))
 370                        ,(if (null? (cddr expr))
 371                             #f
 372                             `(cond ,@(cddr expr))))
 373                   env))
 374           ((and (pair? expr)
 375                 (eq? (car expr) 'set!))
 376            (let ((var (env-lookup env (cadr expr))))
 377              (if (var-global? var)
 378                  (let* ((val (parse 'value (caddr expr) env))
 379                         (r (make-set #f (list val) var)))
 380                    (node-parent-set! val r)
 381                    (var-sets-set! var (cons r (var-sets var)))
 382                    r)
 383                  (compiler-error "set! is only permitted on global variables"))))
 384           ((and (pair? expr) ;; TODO since literal vectors are quoted, this does the job
 385                 (eq? (car expr) 'quote))
 386            (make-cst #f '() (cadr expr)))
 387           ((and (pair? expr)
 388                 (eq? (car expr) 'if))
 389            (let* ((a (parse 'test (cadr expr) env))
 390                   (b (parse use (caddr expr) env))
 391                   (c (if (null? (cdddr expr))
 392                          (make-cst #f '() #f)
 393                          (parse use (cadddr expr) env)))
 394                   (r (make-if #f (list a b c))))
 395              (node-parent-set! a r)
 396              (node-parent-set! b r)
 397              (node-parent-set! c r)
 398              r))
 399           ((and (pair? expr)
 400                 (eq? (car expr) 'lambda))
 401            (let* ((pattern (cadr expr))
 402                   (ids (extract-ids pattern))
 403                   (r (make-prc #f '() #f (has-rest-param? pattern) #f))
 404                   (new-env (env-extend env ids r))
 405                   (body (parse-body (cddr expr) new-env)))
 406              (prc-params-set! r (map (lambda (id) (env-lookup new-env id)) ids))
 407              (node-children-set! r (list body))
 408              (node-parent-set! body r)
 409              r))
 410           ((and (pair? expr)
 411                 (eq? (car expr) 'begin))
 412            (let* ((exprs (map (lambda (x) (parse 'value x env)) (cdr expr)))
 413                   (r (make-seq #f exprs)))
 414              (for-each (lambda (x) (node-parent-set! x r)) exprs)
 415              r))
 416           ((and (pair? expr)
 417                 (eq? (car expr) 'let))
 418            (if (symbol? (cadr expr))
 419                (compiler-error "named let is not implemented")
 420                (parse use
 421                       (cons (cons 'lambda
 422                                   (cons (map car (cadr expr))
 423                                         (cddr expr)))
 424                             (map cadr (cadr expr)))
 425                       env)))
 426           ((and (pair? expr)
 427                 (eq? (car expr) 'let*))
 428            (if (null? (cadr expr))
 429                (parse use
 430                       (cons 'let (cdr expr))
 431                       env)
 432                (parse use
 433                       (list 'let
 434                             (list (list (caar (cadr expr))
 435                                         (cadar (cadr expr))))
 436                             (cons 'let*
 437                                   (cons (cdr (cadr expr))
 438                                         (cddr expr))))
 439                       env)))
 440           ((and (pair? expr)
 441                 (eq? (car expr) 'and))
 442            (cond ((null? (cdr expr))
 443                   (parse use
 444                          #t
 445                          env))
 446                  ((null? (cddr expr))
 447                   (parse use
 448                          (cadr expr)
 449                          env))
 450                  (else
 451                   (parse use
 452                          (list 'if
 453                                (cadr expr)
 454                                (cons 'and (cddr expr))
 455                                #f)
 456                          env))))
 457           ((and (pair? expr)
 458                 (eq? (car expr) 'or))
 459            (cond ((null? (cdr expr))
 460                   (parse use
 461                          #f
 462                          env))
 463                  ((null? (cddr expr))
 464                   (parse use
 465                          (cadr expr)
 466                          env))
 467                  ((eq? use 'test)
 468                   (parse use
 469                          (list 'if
 470                                (cadr expr)
 471                                #t
 472                                (cons 'or (cddr expr)))
 473                          env))
 474                  (else
 475                   (parse use
 476                          (let ((v (gensym)))
 477                            (list 'let
 478                                  (list (list v (cadr expr)))
 479                                  (list 'if
 480                                        v
 481                                        v
 482                                        (cons 'or (cddr expr)))))
 483                          env))))
 484           ((and (pair? expr)
 485                 (memq (car expr)
 486                       '(quote quasiquote unquote unquote-splicing lambda if
 487                         set! cond and or case let let* letrec begin do define
 488                         delay)))
 489            (compiler-error "the compiler does not implement the special form" (car expr)))
 490           ((pair? expr)
 491            (let* ((exprs (map (lambda (x) (parse 'value x env)) expr))
 492                   (r (make-call #f exprs)))
 493              (for-each (lambda (x) (node-parent-set! x r)) exprs)
 494              r))
 495           (else
 496            (compiler-error "unknown expression" expr)))))
 497
 498 (define parse-body
 499   (lambda (exprs env)
 500     (parse 'value (cons 'begin exprs) env)))
 501
 502 (define self-eval?
 503   (lambda (expr)
 504     (or (number? expr)
 505         (char? expr)
 506         (boolean? expr)
 507         (string? expr))))
 508
 509 (define extract-ids
 510   (lambda (pattern)
 511     (if (pair? pattern)
 512         (cons (car pattern) (extract-ids (cdr pattern)))
 513         (if (symbol? pattern)
 514             (cons pattern '())
 515             '()))))
 516
 517 (define has-rest-param?
 518   (lambda (pattern)
 519     (if (pair? pattern)
 520         (has-rest-param? (cdr pattern))
 521         (symbol? pattern))))
 522
 523 ;-----------------------------------------------------------------------------
 524
 525 ;; Compilation context representation.
 526
 527 (define-type context
 528   code
 529   env
 530   env2
 531 )
 532
 533 (define context-change-code
 534   (lambda (ctx code)
 535     (make-context code
 536                   (context-env ctx)
 537                   (context-env2 ctx))))
 538
 539 (define context-change-env
 540   (lambda (ctx env)
 541     (make-context (context-code ctx)
 542                   env
 543                   (context-env2 ctx))))
 544
 545 (define context-change-env2
 546   (lambda (ctx env2)
 547     (make-context (context-code ctx)
 548                   (context-env ctx)
 549                   env2)))
 550
 551 (define make-init-context
 552   (lambda ()
 553     (make-context (make-init-code)
 554                   (make-init-env)
 555                   #f)))
 556
 557 (define context-make-label
 558   (lambda (ctx)
 559     (context-change-code ctx (code-make-label (context-code ctx)))))
 560
 561 (define context-last-label
 562   (lambda (ctx)
 563     (code-last-label (context-code ctx))))
 564
 565 (define context-add-bb
 566   (lambda (ctx label)
 567     (context-change-code ctx (code-add-bb (context-code ctx) label))))
 568
 569 (define context-add-instr
 570   (lambda (ctx instr)
 571     (context-change-code ctx (code-add-instr (context-code ctx) instr))))
 572
 573 ;; Representation of code.
 574
 575 (define-type code
 576   last-label
 577   rev-bbs
 578 )
 579
 580 (define-type bb
 581   label
 582   rev-instrs
 583 )
 584
 585 (define make-init-code
 586   (lambda ()
 587     (make-code 0
 588                (list (make-bb 0 (list))))))
 589
 590 (define code-make-label
 591   (lambda (code)
 592     (let ((label (+ (code-last-label code) 1)))
 593       (make-code label
 594                  (code-rev-bbs code)))))
 595
 596 (define code-add-bb
 597   (lambda (code label)
 598     (make-code
 599      (code-last-label code)
 600      (cons (make-bb label '())
 601            (code-rev-bbs code)))))
 602
 603 (define code-add-instr
 604   (lambda (code instr)
 605     (let* ((rev-bbs (code-rev-bbs code))
 606            (bb (car rev-bbs))
 607            (rev-instrs (bb-rev-instrs bb)))
 608       (make-code
 609        (code-last-label code)
 610        (cons (make-bb (bb-label bb)
 611                       (cons instr rev-instrs))
 612              (cdr rev-bbs))))))
 613
 614 ;; Representation of compile-time stack.
 615
 616 (define-type stack
 617   size  ; number of slots
 618   slots ; for each slot, the variable (or #f) contained in the slot
 619 )
 620
 621 (define make-init-stack
 622   (lambda ()
 623     (make-stack 0 '())))
 624
 625 (define stack-extend
 626   (lambda (x nb-slots stk)
 627     (let ((size (stack-size stk)))
 628       (make-stack
 629        (+ size nb-slots)
 630        (append (repeat nb-slots x) (stack-slots stk))))))
 631
 632 (define stack-discard
 633   (lambda (nb-slots stk)
 634     (let ((size (stack-size stk)))
 635       (make-stack
 636        (- size nb-slots)
 637        (list-tail (stack-slots stk) nb-slots)))))
 638
 639 ;; Representation of compile-time environment.
 640
 641 (define-type env
 642   local
 643   closed
 644 )
 645
 646 (define make-init-env
 647   (lambda ()
 648     (make-env (make-init-stack)
 649               '())))
 650
 651 (define env-change-local
 652   (lambda (env local)
 653     (make-env local
 654               (env-closed env))))
 655
 656 (define env-change-closed
 657   (lambda (env closed)
 658     (make-env (env-local env)
 659               closed)))
 660
 661 (define find-local-var
 662   (lambda (var env)
 663     (let ((i (pos-in-list var (stack-slots (env-local env)))))
 664       (or i
 665           (- (+ (pos-in-list var (env-closed env)) 1))))))
 666
 667 (define prc->env
 668   (lambda (prc)
 669     (make-env
 670      (let ((params (prc-params prc)))
 671        (make-stack (length params)
 672                    (append (map var-id params) '())))
 673      (let ((vars (varset->list (non-global-fv prc))))
 674 ;       (pp (map var-id vars))
 675        (map var-id vars)))))
 676
 677 ;-----------------------------------------------------------------------------
 678
 679 (define gen-instruction
 680   (lambda (instr nb-pop nb-push ctx)
 681     (let* ((env
 682             (context-env ctx))
 683            (stk
 684             (stack-extend #f
 685                           nb-push
 686                           (stack-discard nb-pop
 687                                          (env-local env)))))
 688       (context-add-instr (context-change-env ctx (env-change-local env stk))
 689                          instr))))
 690
 691 (define gen-entry
 692   (lambda (nparams rest? ctx)
 693     (gen-instruction (list 'entry nparams rest?) 0 0 ctx)))
 694
 695 (define gen-push-constant
 696   (lambda (val ctx)
 697     (gen-instruction (list 'push-constant val) 0 1 ctx)))
 698
 699 (define gen-push-unspecified
 700   (lambda (ctx)
 701     (gen-push-constant #f ctx)))
 702
 703 (define gen-push-local-var
 704   (lambda (var ctx)
 705 ;    (pp (list var: var local: (stack-slots (env-local (context-env ctx))) (env-closed (context-env ctx))))
 706     (let ((i (find-local-var var (context-env ctx))))
 707       (if (>= i 0)
 708           (gen-push-stack i ctx)
 709           (gen-push-stack
 710            (+ 1 ;; TODO the +1 was added because closures are not really pairs anymore, they only have a cdr
 711               (- -1 i)
 712               (length (stack-slots (env-local (context-env ctx))))) ctx)))))
 713
 714 (define gen-push-stack
 715   (lambda (pos ctx)
 716     (gen-instruction (list 'push-stack pos) 0 1 ctx)))
 717
 718 (define gen-push-global
 719   (lambda (var ctx)
 720     (gen-instruction (list 'push-global var) 0 1 ctx)))
 721
 722 (define gen-set-global
 723   (lambda (var ctx)
 724     (gen-instruction (list 'set-global var) 1 0 ctx)))
 725
 726 (define gen-call
 727   (lambda (nargs ctx)
 728     (gen-instruction (list 'call nargs) (+ nargs 1) 1 ctx)))
 729
 730 (define gen-jump
 731   (lambda (nargs ctx)
 732     (gen-instruction (list 'jump nargs) (+ nargs 1) 1 ctx)))
 733
 734 (define gen-call-toplevel
 735   (lambda (nargs id ctx)
 736     (gen-instruction (list 'call-toplevel id) nargs 1 ctx)))
 737
 738 (define gen-jump-toplevel
 739   (lambda (nargs id ctx)
 740     (gen-instruction (list 'jump-toplevel id) nargs 1 ctx)))
 741
 742 (define gen-goto
 743   (lambda (label ctx)
 744     (gen-instruction (list 'goto label) 0 0 ctx)))
 745
 746 (define gen-goto-if-false
 747   (lambda (label-false label-true ctx)
 748     (gen-instruction (list 'goto-if-false label-false label-true) 1 0 ctx)))
 749
 750 (define gen-closure
 751   (lambda (label-entry ctx)
 752     (gen-instruction (list 'closure label-entry) 1 1 ctx)))
 753
 754 (define gen-prim
 755   (lambda (id nargs unspec-result? ctx)
 756     (gen-instruction
 757      (list 'prim id)
 758      nargs
 759      (if unspec-result? 0 1)
 760      ctx)))
 761
 762 (define gen-shift
 763   (lambda (n ctx)
 764     (if (> n 0)
 765         (gen-instruction (list 'shift) 1 0 (gen-shift (- n 1) ctx))
 766         ctx)))
 767
 768 (define gen-pop
 769   (lambda (ctx)
 770     (gen-instruction (list 'pop) 1 0 ctx)))
 771
 772 (define gen-return
 773   (lambda (ctx)
 774     (let ((ss (stack-size (env-local (context-env ctx)))))
 775       (gen-instruction (list 'return) ss 0 ctx))))
 776
 777 ;-----------------------------------------------------------------------------
 778
 779 (define child1
 780   (lambda (node)
 781     (car (node-children node))))
 782
 783 (define child2
 784   (lambda (node)
 785     (cadr (node-children node))))
 786
 787 (define child3
 788   (lambda (node)
 789     (caddr (node-children node))))
 790
 791 (define comp-none
 792   (lambda (node ctx)
 793
 794     (cond ((or (cst? node)
 795                (ref? node)
 796                (prc? node))
 797            ctx)
 798
 799           ((def? node)
 800            (let ((var (def-var node)))
 801              (if (toplevel-prc-with-non-rest-correct-calls? var)
 802                  (comp-prc (child1 node) #f ctx)
 803                  (if (var-needed? var)
 804                      (let ((ctx2 (comp-push (child1 node) ctx)))
 805                        (gen-set-global (var-id var) ctx2))
 806                      (comp-none (child1 node) ctx)))))
 807
 808           ((set? node)
 809            (let ((var (set-var node)))
 810              (if (var-needed? var)
 811                  (let ((ctx2 (comp-push (child1 node) ctx)))
 812                    (gen-set-global (var-id var) ctx2))
 813                  (comp-none (child1 node) ctx))))
 814
 815           ((if? node)
 816            (let* ((ctx2
 817                    (context-make-label ctx))
 818                   (label-then
 819                    (context-last-label ctx2))
 820                   (ctx3
 821                    (context-make-label ctx2))
 822                   (label-else
 823                    (context-last-label ctx3))
 824                   (ctx4
 825                    (context-make-label ctx3))
 826                   (label-then-join
 827                    (context-last-label ctx4))
 828                   (ctx5
 829                    (context-make-label ctx4))
 830                   (label-else-join
 831                    (context-last-label ctx5))
 832                   (ctx6
 833                    (context-make-label ctx5))
 834                   (label-join
 835                    (context-last-label ctx6))
 836                   (ctx7
 837                    (comp-test (child1 node) label-then label-else ctx6))
 838                   (ctx8
 839                    (gen-goto
 840                     label-else-join
 841                     (comp-none (child3 node)
 842                                (context-change-env2
 843                                 (context-add-bb ctx7 label-else)
 844                                 #f))))
 845                   (ctx9
 846                    (gen-goto
 847                     label-then-join
 848                     (comp-none (child2 node)
 849                                (context-change-env
 850                                 (context-add-bb ctx8 label-then)
 851                                 (context-env2 ctx7)))))
 852                   (ctx10
 853                    (gen-goto
 854                     label-join
 855                     (context-add-bb ctx9 label-else-join)))
 856                   (ctx11
 857                    (gen-goto
 858                     label-join
 859                     (context-add-bb ctx10 label-then-join)))
 860                   (ctx12
 861                    (context-add-bb ctx11 label-join)))
 862              ctx12))
 863
 864           ((call? node)
 865            (comp-call node 'none ctx))
 866
 867           ((seq? node)
 868            (let ((children (node-children node)))
 869              (if (null? children)
 870                  ctx
 871                  (let loop ((lst children)
 872                             (ctx ctx))
 873                    (if (null? (cdr lst))
 874                        (comp-none (car lst) ctx)
 875                        (loop (cdr lst)
 876                              (comp-none (car lst) ctx)))))))
 877
 878           (else
 879            (compiler-error "unknown expression type" node)))))
 880
 881 (define comp-tail
 882   (lambda (node ctx)
 883
 884     (cond ((or (cst? node)
 885                (ref? node)
 886                (def? node)
 887                (set? node)
 888                (prc? node)
 889 ;               (call? node)
 890                )
 891            (gen-return (comp-push node ctx)))
 892
 893           ((if? node)
 894            (let* ((ctx2
 895                    (context-make-label ctx))
 896                   (label-then
 897                    (context-last-label ctx2))
 898                   (ctx3
 899                    (context-make-label ctx2))
 900                   (label-else
 901                    (context-last-label ctx3))
 902                   (ctx4
 903                    (comp-test (child1 node) label-then label-else ctx3))
 904                   (ctx5
 905                    (comp-tail (child3 node)
 906                               (context-change-env2
 907                                (context-add-bb ctx4 label-else)
 908                                #f)))
 909                   (ctx6
 910                    (comp-tail (child2 node)
 911                               (context-change-env
 912                                (context-add-bb ctx5 label-then)
 913                                (context-env2 ctx4)))))
 914              ctx6))
 915
 916           ((call? node)
 917            (comp-call node 'tail ctx))
 918
 919           ((seq? node)
 920            (let ((children (node-children node)))
 921              (if (null? children)
 922                  (gen-return (gen-push-unspecified ctx))
 923                  (let loop ((lst children)
 924                             (ctx ctx))
 925                    (if (null? (cdr lst))
 926                        (comp-tail (car lst) ctx)
 927                        (loop (cdr lst)
 928                              (comp-none (car lst) ctx)))))))
 929
 930           (else
 931            (compiler-error "unknown expression type" node)))))
 932
 933 (define comp-push
 934   (lambda (node ctx)
 935
 936     '(
 937     (display "--------------\n")
 938     (pp (node->expr node))
 939     (pp env)
 940     (pp stk)
 941      )
 942
 943     (cond ((cst? node)
 944            (let ((val (cst-val node)))
 945              (gen-push-constant val ctx)))
 946
 947           ((ref? node)
 948            (let ((var (ref-var node)))
 949              (if (var-global? var)
 950                  (if (null? (var-defs var))
 951                      (compiler-error "undefined variable:" (var-id var))
 952                      (let ((val (child1 (car (var-defs var)))))
 953                        (if (and (not (mutable-var? var))
 954                                 (cst? val)) ;; immutable global, counted as cst
 955                            (gen-push-constant (cst-val val) ctx)
 956                            (gen-push-global (var-id var) ctx))))
 957                  (gen-push-local-var (var-id var) ctx)))) ;; TODO globals as csts seem to work (but only for constant-values ones, like it probably should)
 958
 959           ((or (def? node)
 960                (set? node))
 961            (gen-push-unspecified (comp-none node ctx)))
 962
 963           ((if? node)
 964            (let* ((ctx2
 965                    (context-make-label ctx))
 966                   (label-then
 967                    (context-last-label ctx2))
 968                   (ctx3
 969                    (context-make-label ctx2))
 970                   (label-else
 971                    (context-last-label ctx3))
 972                   (ctx4
 973                    (context-make-label ctx3))
 974                   (label-then-join
 975                    (context-last-label ctx4))
 976                   (ctx5
 977                    (context-make-label ctx4))
 978                   (label-else-join
 979                    (context-last-label ctx5))
 980                   (ctx6
 981                    (context-make-label ctx5))
 982                   (label-join
 983                    (context-last-label ctx6))
 984                   (ctx7
 985                    (comp-test (child1 node) label-then label-else ctx6))
 986                   (ctx8
 987                    (gen-goto
 988                     label-else-join
 989                     (comp-push (child3 node)
 990                                (context-change-env2
 991                                 (context-add-bb ctx7 label-else)
 992                                 #f))))
 993                   (ctx9
 994                    (gen-goto
 995                     label-then-join
 996                     (comp-push (child2 node)
 997                                (context-change-env
 998                                 (context-add-bb ctx8 label-then)
 999                                 (context-env2 ctx7)))))
1000                   (ctx10
1001                    (gen-goto
1002                     label-join
1003                     (context-add-bb ctx9 label-else-join)))
1004                   (ctx11
1005                    (gen-goto
1006                     label-join
1007                     (context-add-bb ctx10 label-then-join)))
1008                   (ctx12
1009                    (context-add-bb ctx11 label-join)))
1010              ctx12))
1011
1012           ((prc? node)
1013            (comp-prc node #t ctx))
1014
1015           ((call? node)
1016            (comp-call node 'push ctx))
1017
1018           ((seq? node)
1019            (let ((children (node-children node)))
1020              (if (null? children)
1021                  (gen-push-unspecified ctx)
1022                  (let loop ((lst children)
1023                             (ctx ctx))
1024                    (if (null? (cdr lst))
1025                        (comp-push (car lst) ctx)
1026                        (loop (cdr lst)
1027                              (comp-none (car lst) ctx)))))))
1028
1029           (else
1030            (compiler-error "unknown expression type" node)))))
1031
1032 (define (build-closure label-entry vars ctx)
1033
1034   (define (build vars ctx)
1035     (if (null? vars)
1036         (gen-push-constant '() ctx)
1037         (gen-prim '#%cons
1038                   2
1039                   #f
1040                   (build (cdr vars)
1041                          (gen-push-local-var (car vars) ctx)))))
1042
1043   (if (null? vars)
1044       (gen-closure label-entry
1045                    (gen-push-constant '() ctx))
1046       (gen-closure label-entry
1047                    (build vars ctx))))
1048 ;; TODO the last branch was changed because since pointers are now larger, there is not a pointer-sized free space in each closure, which could make it behave like a pair. now, everything is in the env, and closures only have a cdr
1049
1050 (define comp-prc
1051   (lambda (node closure? ctx)
1052     (let* ((ctx2
1053             (context-make-label ctx))
1054            (label-entry
1055             (context-last-label ctx2))
1056            (ctx3
1057             (context-make-label ctx2))
1058            (label-continue
1059             (context-last-label ctx3))
1060            (body-env
1061             (prc->env node))
1062            (ctx4
1063             (if closure?
1064                 (build-closure label-entry (env-closed body-env) ctx3)
1065                 ctx3))
1066            (ctx5
1067             (gen-goto label-continue ctx4))
1068            (ctx6
1069             (gen-entry (length (prc-params node))
1070                        (prc-rest? node)
1071                        (context-add-bb (context-change-env ctx5
1072                                                            body-env)
1073                                        label-entry)))
1074            (ctx7
1075             (comp-tail (child1 node) ctx6)))
1076       (prc-entry-label-set! node label-entry)
1077       (context-add-bb (context-change-env ctx7 (context-env ctx5))
1078                       label-continue))))
1079
1080 (define comp-call
1081   (lambda (node reason ctx)
1082     (let* ((op (child1 node))
1083            (args (cdr (node-children node)))
1084            (nargs (length args)))
1085       (let loop ((lst args)
1086                  (ctx ctx))
1087         (if (pair? lst)
1088
1089             (let ((arg (car lst)))
1090               (loop (cdr lst)
1091                     (comp-push arg ctx)))
1092
1093             (cond ((and (ref? op)
1094                         (var-primitive (ref-var op)))
1095                    (let* ((var (ref-var op))
1096                           (id (var-id var))
1097                           (primitive (var-primitive var))
1098                           (prim-nargs (primitive-nargs primitive)))
1099
1100                      (define use-result
1101                        (lambda (ctx2)
1102                          (cond ((eq? reason 'tail)
1103                                 (gen-return
1104                                  (if (primitive-unspecified-result? primitive)
1105                                      (gen-push-unspecified ctx2)
1106                                      ctx2)))
1107                                ((eq? reason 'push)
1108                                 (if (primitive-unspecified-result? primitive)
1109                                     (gen-push-unspecified ctx2)
1110                                     ctx2))
1111                                (else
1112                                 (if (primitive-unspecified-result? primitive)
1113                                     ctx2
1114                                     (gen-pop ctx2))))))
1115
1116                      (use-result
1117                       (if (primitive-inliner primitive)
1118                           ((primitive-inliner primitive) ctx)
1119                           (if (not (= nargs prim-nargs))
1120                               (compiler-error "primitive called with wrong number of arguments" id)
1121                               (gen-prim
1122                                id
1123                                prim-nargs
1124                                (primitive-unspecified-result? primitive)
1125                                ctx))))))
1126
1127
1128                   ((and (ref? op)
1129                         (toplevel-prc-with-non-rest-correct-calls? (ref-var op)))
1130                    =>
1131                    (lambda (prc)
1132                      (cond ((eq? reason 'tail)
1133                             (gen-jump-toplevel nargs prc ctx))
1134                            ((eq? reason 'push)
1135                             (gen-call-toplevel nargs prc ctx))
1136                            (else
1137                             (gen-pop (gen-call-toplevel nargs prc ctx))))))
1138
1139                   (else
1140                    (let ((ctx2 (comp-push op ctx)))
1141                      (cond ((eq? reason 'tail)
1142                             (gen-jump nargs ctx2))
1143                            ((eq? reason 'push)
1144                             (gen-call nargs ctx2))
1145                            (else
1146                             (gen-pop (gen-call nargs ctx2))))))))))))
1147
1148 (define comp-test
1149   (lambda (node label-true label-false ctx)
1150     (cond ((cst? node)
1151            (let ((ctx2
1152                   (gen-goto
1153                    (let ((val (cst-val node)))
1154                      (if val
1155                          label-true
1156                          label-false))
1157                    ctx)))
1158              (context-change-env2 ctx2 (context-env ctx2))))
1159
1160           ((or (ref? node)
1161                (def? node)
1162                (set? node)
1163                (if? node)
1164                (call? node)
1165                (seq? node))
1166            (let* ((ctx2
1167                    (comp-push node ctx))
1168                   (ctx3
1169                    (gen-goto-if-false label-false label-true ctx2)))
1170              (context-change-env2 ctx3 (context-env ctx3))))
1171
1172           ((prc? node)
1173            (let ((ctx2
1174                   (gen-goto label-true ctx)))
1175              (context-change-env2 ctx2 (context-env ctx2))))
1176
1177           (else
1178            (compiler-error "unknown expression type" node)))))
1179
1180 ;-----------------------------------------------------------------------------
1181
1182 (define toplevel-prc?
1183   (lambda (var)
1184     (and (not (mutable-var? var))
1185          (let ((d (var-defs var)))
1186            (and (pair? d)
1187                 (null? (cdr d))
1188                 (let ((val (child1 (car d))))
1189                   (and (prc? val)
1190                        val)))))))
1191
1192 (define toplevel-prc-with-non-rest-correct-calls?
1193   (lambda (var)
1194     (let ((prc (toplevel-prc? var)))
1195       (and prc
1196            (not (prc-rest? prc))
1197            (every (lambda (r)
1198                     (let ((parent (node-parent r)))
1199                       (and (call? parent)
1200                            (eq? (child1 parent) r)
1201                            (= (length (prc-params prc))
1202                               (- (length (node-children parent)) 1)))))
1203                   (var-refs var))
1204            prc))))
1205
1206 (define mutable-var?
1207   (lambda (var)
1208     (not (null? (var-sets var)))))
1209
1210 (define global-fv
1211   (lambda (node)
1212     (list->varset
1213      (keep var-global?
1214            (varset->list (fv node))))))
1215
1216 (define non-global-fv
1217   (lambda (node)
1218     (list->varset
1219      (keep (lambda (x) (not (var-global? x)))
1220            (varset->list (fv node))))))
1221
1222 (define fv
1223   (lambda (node)
1224     (cond ((cst? node)
1225            (varset-empty))
1226           ((ref? node)
1227            (let ((var (ref-var node)))
1228              (varset-singleton var)))
1229           ((def? node)
1230            (let ((var (def-var node))
1231                  (val (child1 node)))
1232              (varset-union
1233               (varset-singleton var)
1234               (fv val))))
1235           ((set? node)
1236            (let ((var (set-var node))
1237                  (val (child1 node)))
1238              (varset-union
1239               (varset-singleton var)
1240               (fv val))))
1241           ((if? node)
1242            (let ((a (list-ref (node-children node) 0))
1243                  (b (list-ref (node-children node) 1))
1244                  (c (list-ref (node-children node) 2)))
1245              (varset-union-multi (list (fv a) (fv b) (fv c)))))
1246           ((prc? node)
1247            (let ((body (list-ref (node-children node) 0)))
1248              (varset-difference
1249               (fv body)
1250               (build-params-varset (prc-params node)))))
1251           ((call? node)
1252            (varset-union-multi (map fv (node-children node))))
1253           ((seq? node)
1254            (varset-union-multi (map fv (node-children node))))
1255           (else
1256            (compiler-error "unknown expression type" node)))))
1257
1258 (define build-params-varset
1259   (lambda (params)
1260     (list->varset params)))
1261
1262 (define mark-needed-global-vars!
1263   (lambda (global-env node)
1264
1265     (define readyq
1266       (env-lookup global-env '#%readyq))
1267
1268     (define mark-var!
1269       (lambda (var)
1270         (if (and (var-global? var)
1271                  (not (var-needed? var))
1272                  ;; globals that obey the following conditions are considered
1273                  ;; to be constants
1274                  (not (and (not (mutable-var? var))
1275                            (> (length (var-defs var)) 0) ;; TODO to catch errors for primitives
1276                            (cst? (child1 (car (var-defs var)))))))
1277             (begin
1278               (var-needed?-set! var #t)
1279               (for-each
1280                (lambda (def)
1281                  (let ((val (child1 def)))
1282                    (if (side-effect-less? val)
1283                        (mark! val))))
1284                (var-defs var))
1285               (if (eq? var readyq)
1286                   (begin
1287                     (mark-var!
1288                      (env-lookup global-env '#%start-first-process))
1289                     (mark-var!
1290                      (env-lookup global-env '#%exit))))))))
1291
1292     (define side-effect-less?
1293       (lambda (node)
1294         (or (cst? node)
1295             (ref? node)
1296             (prc? node))))
1297
1298     (define mark!
1299       (lambda (node)
1300         (cond ((cst? node))
1301               ((ref? node)
1302                (let ((var (ref-var node)))
1303                  (mark-var! var)))
1304               ((def? node)
1305                (let ((var (def-var node))
1306                      (val (child1 node)))
1307                  (if (not (side-effect-less? val))
1308                      (mark! val))))
1309               ((set? node)
1310                (let ((var (set-var node))
1311                      (val (child1 node)))
1312                  (mark! val)))
1313               ((if? node)
1314                (let ((a (list-ref (node-children node) 0))
1315                      (b (list-ref (node-children node) 1))
1316                      (c (list-ref (node-children node) 2)))
1317                  (mark! a)
1318                  (mark! b)
1319                  (mark! c)))
1320               ((prc? node)
1321                (let ((body (list-ref (node-children node) 0)))
1322                  (mark! body)))
1323               ((call? node)
1324                (for-each mark! (node-children node)))
1325               ((seq? node)
1326                (for-each mark! (node-children node)))
1327               (else
1328                (compiler-error "unknown expression type" node)))))
1329
1330     (mark! node)
1331 ))
1332
1333 ;-----------------------------------------------------------------------------
1334
1335 ;; Variable sets
1336
1337 (define (varset-empty)              ; return the empty set
1338   '())
1339
1340 (define (varset-singleton x)        ; create a set containing only 'x'
1341   (list x))
1342
1343 (define (list->varset lst)          ; convert list to set
1344   lst)
1345
1346 (define (varset->list set)          ; convert set to list
1347   set)
1348
1349 (define (varset-size set)           ; return cardinality of set
1350   (list-length set))
1351
1352 (define (varset-empty? set)         ; is 'x' the empty set?
1353   (null? set))
1354
1355 (define (varset-member? x set)      ; is 'x' a member of the 'set'?
1356   (and (not (null? set))
1357        (or (eq? x (car set))
1358            (varset-member? x (cdr set)))))
1359
1360 (define (varset-adjoin set x)       ; add the element 'x' to the 'set'
1361   (if (varset-member? x set) set (cons x set)))
1362
1363 (define (varset-remove set x)       ; remove the element 'x' from 'set'
1364   (cond ((null? set)
1365          '())
1366         ((eq? (car set) x)
1367          (cdr set))
1368         (else
1369          (cons (car set) (varset-remove (cdr set) x)))))
1370
1371 (define (varset-equal? s1 s2)       ; are 's1' and 's2' equal sets?
1372   (and (varset-subset? s1 s2)
1373        (varset-subset? s2 s1)))
1374
1375 (define (varset-subset? s1 s2)      ; is 's1' a subset of 's2'?
1376   (cond ((null? s1)
1377          #t)
1378         ((varset-member? (car s1) s2)
1379          (varset-subset? (cdr s1) s2))
1380         (else
1381          #f)))
1382
1383 (define (varset-difference set1 set2) ; return difference of sets
1384   (cond ((null? set1)
1385          '())
1386         ((varset-member? (car set1) set2)
1387          (varset-difference (cdr set1) set2))
1388         (else
1389          (cons (car set1) (varset-difference (cdr set1) set2)))))
1390
1391 (define (varset-union set1 set2)    ; return union of sets
1392   (define (union s1 s2)
1393     (cond ((null? s1)
1394            s2)
1395           ((varset-member? (car s1) s2)
1396            (union (cdr s1) s2))
1397           (else
1398            (cons (car s1) (union (cdr s1) s2)))))
1399   (if (varset-smaller? set1 set2)
1400     (union set1 set2)
1401     (union set2 set1)))
1402
1403 (define (varset-intersection set1 set2) ; return intersection of sets
1404   (define (intersection s1 s2)
1405     (cond ((null? s1)
1406            '())
1407           ((varset-member? (car s1) s2)
1408            (cons (car s1) (intersection (cdr s1) s2)))
1409           (else
1410            (intersection (cdr s1) s2))))
1411   (if (varset-smaller? set1 set2)
1412     (intersection set1 set2)
1413     (intersection set2 set1)))
1414
1415 (define (varset-intersects? set1 set2) ; do sets 'set1' and 'set2' intersect?
1416   (not (varset-empty? (varset-intersection set1 set2))))
1417
1418 (define (varset-smaller? set1 set2)
1419   (if (null? set1)
1420     (not (null? set2))
1421     (if (null? set2)
1422       #f
1423       (varset-smaller? (cdr set1) (cdr set2)))))
1424
1425 (define (varset-union-multi sets)
1426   (if (null? sets)
1427     (varset-empty)
1428     (n-ary varset-union (car sets) (cdr sets))))
1429
1430 (define (n-ary function first rest)
1431   (if (null? rest)
1432     first
1433     (n-ary function (function first (car rest)) (cdr rest))))
1434
1435 ;------------------------------------------------------------------------------
1436
1437 (define code->vector
1438   (lambda (code)
1439     (let ((v (make-vector (+ (code-last-label code) 1))))
1440       (for-each
1441        (lambda (bb)
1442          (vector-set! v (bb-label bb) bb))
1443        (code-rev-bbs code))
1444       v)))
1445
1446 (define bbs->ref-counts
1447   (lambda (bbs)
1448     (let ((ref-counts (make-vector (vector-length bbs) 0)))
1449
1450       (define visit
1451         (lambda (label)
1452           (let ((ref-count (vector-ref ref-counts label)))
1453             (vector-set! ref-counts label (+ ref-count 1))
1454             (if (= ref-count 0)
1455                 (let* ((bb (vector-ref bbs label))
1456                        (rev-instrs (bb-rev-instrs bb)))
1457                   (for-each
1458                    (lambda (instr)
1459                      (let ((opcode (car instr)))
1460                        (cond ((eq? opcode 'goto)
1461                               (visit (cadr instr)))
1462                              ((eq? opcode 'goto-if-false)
1463                               (visit (cadr instr))
1464                               (visit (caddr instr)))
1465                              ((or (eq? opcode 'closure)
1466                                   (eq? opcode 'call-toplevel)
1467                                   (eq? opcode 'jump-toplevel))
1468                               (visit (cadr instr))))))
1469                    rev-instrs))))))
1470
1471       (visit 0)
1472
1473       ref-counts)))
1474
1475 (define resolve-toplevel-labels!
1476   (lambda (bbs)
1477     (let loop ((i 0))
1478       (if (< i (vector-length bbs))
1479           (let* ((bb (vector-ref bbs i))
1480                  (rev-instrs (bb-rev-instrs bb)))
1481             (bb-rev-instrs-set!
1482              bb
1483              (map (lambda (instr)
1484                     (let ((opcode (car instr)))
1485                       (cond ((eq? opcode 'call-toplevel)
1486                              (list opcode
1487                                    (prc-entry-label (cadr instr))))
1488                             ((eq? opcode 'jump-toplevel)
1489                              (list opcode
1490                                    (prc-entry-label (cadr instr))))
1491                             (else
1492                              instr))))
1493                   rev-instrs))
1494             (loop (+ i 1)))))))
1495
1496 (define tighten-jump-cascades!
1497   (lambda (bbs)
1498     (let ((ref-counts (bbs->ref-counts bbs)))
1499
1500       (define resolve
1501         (lambda (label)
1502           (let* ((bb (vector-ref bbs label))
1503                  (rev-instrs (bb-rev-instrs bb)))
1504             (and (or (null? (cdr rev-instrs))
1505                      (= (vector-ref ref-counts label) 1))
1506                  rev-instrs))))
1507
1508       (let loop1 ()
1509         (let loop2 ((i 0)
1510                     (changed? #f))
1511           (if (< i (vector-length bbs))
1512               (if (> (vector-ref ref-counts i) 0)
1513                   (let* ((bb (vector-ref bbs i))
1514                          (rev-instrs (bb-rev-instrs bb))
1515                          (jump (car rev-instrs))
1516                          (opcode (car jump)))
1517                     (cond ((eq? opcode 'goto)
1518                            (let* ((label (cadr jump))
1519                                   (jump-replacement (resolve label)))
1520                              (if jump-replacement
1521                                  (begin
1522                                    (vector-set!
1523                                     bbs
1524                                     i
1525                                     (make-bb (bb-label bb)
1526                                              (append jump-replacement
1527                                                      (cdr rev-instrs))))
1528                                    (loop2 (+ i 1)
1529                                           #t))
1530                                  (loop2 (+ i 1)
1531                                         changed?))))
1532                           ((eq? opcode 'goto-if-false)
1533                            (let* ((label-then (cadr jump))
1534                                   (label-else (caddr jump))
1535                                   (jump-then-replacement (resolve label-then))
1536                                   (jump-else-replacement (resolve label-else)))
1537                              (if (and jump-then-replacement
1538                                       (null? (cdr jump-then-replacement))
1539                                       jump-else-replacement
1540                                       (null? (cdr jump-else-replacement))
1541                                       (or (eq? (caar jump-then-replacement) 'goto)
1542                                           (eq? (caar jump-else-replacement) 'goto)))
1543                                  (begin
1544                                    (vector-set!
1545                                     bbs
1546                                     i
1547                                     (make-bb (bb-label bb)
1548                                              (cons (list 'goto-if-false
1549                                                          (if (eq? (caar jump-then-replacement) 'goto)
1550                                                              (cadar jump-then-replacement)
1551                                                              label-then)
1552                                                          (if (eq? (caar jump-else-replacement) 'goto)
1553                                                              (cadar jump-else-replacement)
1554                                                              label-else))
1555                                                    (cdr rev-instrs))))
1556                                    (loop2 (+ i 1)
1557                                           #t))
1558                                  (loop2 (+ i 1)
1559                                         changed?))))
1560                           (else
1561                            (loop2 (+ i 1)
1562                                   changed?))))
1563                   (loop2 (+ i 1)
1564                          changed?))
1565               (if changed?
1566                   (loop1))))))))
1567
1568 (define remove-useless-bbs!
1569   (lambda (bbs)
1570     (let ((ref-counts (bbs->ref-counts bbs)))
1571       (let loop1 ((label 0) (new-label 0))
1572         (if (< label (vector-length bbs))
1573             (if (> (vector-ref ref-counts label) 0)
1574                 (let ((bb (vector-ref bbs label)))
1575                   (vector-set!
1576                    bbs
1577                    label
1578                    (make-bb new-label (bb-rev-instrs bb)))
1579                   (loop1 (+ label 1) (+ new-label 1)))
1580                 (loop1 (+ label 1) new-label))
1581             (renumber-labels bbs ref-counts new-label))))))
1582
1583 (define renumber-labels
1584   (lambda (bbs ref-counts n)
1585     (let ((new-bbs (make-vector n)))
1586       (let loop2 ((label 0))
1587         (if (< label (vector-length bbs))
1588             (if (> (vector-ref ref-counts label) 0)
1589                 (let* ((bb (vector-ref bbs label))
1590                        (new-label (bb-label bb))
1591                        (rev-instrs (bb-rev-instrs bb)))
1592
1593                   (define fix
1594                     (lambda (instr)
1595
1596                       (define new-label
1597                         (lambda (label)
1598                           (bb-label (vector-ref bbs label))))
1599
1600                       (let ((opcode (car instr)))
1601                         (cond ((eq? opcode 'closure)
1602                                (list 'closure
1603                                      (new-label (cadr instr))))
1604                               ((eq? opcode 'call-toplevel)
1605                                (list 'call-toplevel
1606                                      (new-label (cadr instr))))
1607                               ((eq? opcode 'jump-toplevel)
1608                                (list 'jump-toplevel
1609                                      (new-label (cadr instr))))
1610                               ((eq? opcode 'goto)
1611                                (list 'goto
1612                                      (new-label (cadr instr))))
1613                               ((eq? opcode 'goto-if-false)
1614                                (list 'goto-if-false
1615                                      (new-label (cadr instr))
1616                                      (new-label (caddr instr))))
1617                               (else
1618                                instr)))))
1619
1620                   (vector-set!
1621                    new-bbs
1622                    new-label
1623                    (make-bb new-label (map fix rev-instrs)))
1624                   (loop2 (+ label 1)))
1625                 (loop2 (+ label 1)))
1626             new-bbs)))))
1627
1628 (define reorder!
1629   (lambda (bbs)
1630     (let* ((done (make-vector (vector-length bbs) #f)))
1631
1632       (define unscheduled?
1633         (lambda (label)
1634           (not (vector-ref done label))))
1635
1636       (define label-refs
1637         (lambda (instrs todo)
1638           (if (pair? instrs)
1639               (let* ((instr (car instrs))
1640                      (opcode (car instr)))
1641                 (cond ((or (eq? opcode 'closure)
1642                            (eq? opcode 'call-toplevel)
1643                            (eq? opcode 'jump-toplevel))
1644                        (label-refs (cdr instrs) (cons (cadr instr) todo)))
1645                       (else
1646                        (label-refs (cdr instrs) todo))))
1647               todo)))
1648
1649       (define schedule-here
1650         (lambda (label new-label todo cont)
1651           (let* ((bb (vector-ref bbs label))
1652                  (rev-instrs (bb-rev-instrs bb))
1653                  (jump (car rev-instrs))
1654                  (opcode (car jump))
1655                  (new-todo (label-refs rev-instrs todo)))
1656             (vector-set! bbs label (make-bb new-label rev-instrs))
1657             (vector-set! done label #t)
1658             (cond ((eq? opcode 'goto)
1659                    (let ((label (cadr jump)))
1660                      (if (unscheduled? label)
1661                          (schedule-here label
1662                                         (+ new-label 1)
1663                                         new-todo
1664                                         cont)
1665                          (cont (+ new-label 1)
1666                                new-todo))))
1667                   ((eq? opcode 'goto-if-false)
1668                    (let ((label-then (cadr jump))
1669                          (label-else (caddr jump)))
1670                      (cond ((unscheduled? label-else)
1671                             (schedule-here label-else
1672                                            (+ new-label 1)
1673                                            (cons label-then new-todo)
1674                                            cont))
1675                            ((unscheduled? label-then)
1676                             (schedule-here label-then
1677                                            (+ new-label 1)
1678                                            new-todo
1679                                            cont))
1680                            (else
1681                             (cont (+ new-label 1)
1682                                   new-todo)))))
1683                   (else
1684                    (cont (+ new-label 1)
1685                          new-todo))))))
1686
1687       (define schedule-somewhere
1688         (lambda (label new-label todo cont)
1689           (schedule-here label new-label todo cont)))
1690
1691       (define schedule-todo
1692         (lambda (new-label todo)
1693           (if (pair? todo)
1694               (let ((label (car todo)))
1695                 (if (unscheduled? label)
1696                     (schedule-somewhere label
1697                                         new-label
1698                                         (cdr todo)
1699                                         schedule-todo)
1700                     (schedule-todo new-label
1701                                    (cdr todo)))))))
1702
1703
1704       (schedule-here 0 0 '() schedule-todo)
1705
1706       (renumber-labels bbs
1707                        (make-vector (vector-length bbs) 1)
1708                        (vector-length bbs)))))
1709
1710 (define linearize
1711   (lambda (bbs)
1712     (let loop ((label (- (vector-length bbs) 1))
1713                (lst '()))
1714       (if (>= label 0)
1715           (let* ((bb (vector-ref bbs label))
1716                  (rev-instrs (bb-rev-instrs bb))
1717                  (jump (car rev-instrs))
1718                  (opcode (car jump)))
1719             (loop (- label 1)
1720                   (append
1721                    (list label)
1722                    (reverse
1723                     (cond ((eq? opcode 'goto)
1724                            (if (= (cadr jump) (+ label 1))
1725                                (cdr rev-instrs)
1726                                rev-instrs))
1727                           ((eq? opcode 'goto-if-false)
1728                            (cond ((= (caddr jump) (+ label 1))
1729                                   (cons (list 'goto-if-false (cadr jump))
1730                                         (cdr rev-instrs)))
1731                                  ((= (cadr jump) (+ label 1))
1732                                   (cons (list 'goto-if-not-false (caddr jump))
1733                                         (cdr rev-instrs)))
1734                                  (else
1735                                   (cons (list 'goto (caddr jump))
1736                                         (cons (list 'goto-if-false (cadr jump))
1737                                               (cdr rev-instrs))))))
1738                           (else
1739                            rev-instrs)))
1740                    lst)))
1741           lst))))
1742
1743 (define optimize-code
1744   (lambda (code)
1745     (let ((bbs (code->vector code)))
1746       (resolve-toplevel-labels! bbs)
1747       (tighten-jump-cascades! bbs)
1748       (let ((bbs (remove-useless-bbs! bbs)))
1749         (reorder! bbs)))))
1750
1751
1752 (define expand-loads
1753   (lambda (exprs)
1754     (map (lambda (e)
1755            (if (eq? (car e) 'load)
1756                (cons 'begin
1757                      (expand-loads (with-input-from-file (cadr e) read-all)))
1758                e))
1759          exprs)))
1760
1761 (define parse-file
1762   (lambda (filename)
1763     (let* ((library
1764             (with-input-from-file "library.scm" read-all))
1765            (toplevel-exprs
1766             (expand-loads (append library
1767                                   (with-input-from-file filename read-all))))
1768            (global-env
1769             (make-global-env))
1770            (parsed-prog
1771             (parse-top (cons 'begin toplevel-exprs) global-env)))
1772
1773       (for-each
1774        (lambda (node)
1775          (mark-needed-global-vars! global-env node))
1776        parsed-prog)
1777
1778       (extract-parts
1779        parsed-prog
1780        (lambda (defs after-defs)
1781
1782          (define make-seq-preparsed
1783            (lambda (exprs)
1784              (let ((r (make-seq #f exprs)))
1785                (for-each (lambda (x) (node-parent-set! x r)) exprs)
1786                r)))
1787
1788          (define make-call-preparsed
1789            (lambda (exprs)
1790              (let ((r (make-call #f exprs)))
1791                (for-each (lambda (x) (node-parent-set! x r)) exprs)
1792                r)))
1793
1794          (if (var-needed?
1795               (env-lookup global-env '#%readyq))
1796              (make-seq-preparsed
1797               (list (make-seq-preparsed defs)
1798                     (make-call-preparsed
1799                      (list (parse 'value '#%start-first-process global-env)
1800                            (let* ((pattern
1801                                    '())
1802                                   (ids
1803                                    (extract-ids pattern))
1804                                   (r
1805                                    (make-prc #f '() #f (has-rest-param? pattern) #f))
1806                                   (new-env
1807                                    (env-extend global-env ids r))
1808                                   (body
1809                                    (make-seq-preparsed after-defs)))
1810                              (prc-params-set!
1811                               r
1812                               (map (lambda (id) (env-lookup new-env id))
1813                                    ids))
1814                              (node-children-set! r (list body))
1815                              (node-parent-set! body r)
1816                              r)))
1817                     (parse 'value
1818                            '(#%exit)
1819                            global-env)))
1820              (make-seq-preparsed
1821               (append defs
1822                       after-defs
1823                       (list (parse 'value
1824                                    '(#%halt)
1825                                    global-env))))))))))
1826
1827 (define extract-parts
1828   (lambda (lst cont)
1829     (if (or (null? lst)
1830             (not (def? (car lst))))
1831         (cont '() lst)
1832         (extract-parts
1833          (cdr lst)
1834          (lambda (d ad)
1835            (cont (cons (car lst) d) ad))))))
1836
1837 ;------------------------------------------------------------------------------
1838
1839 ;;(include "asm.scm")
1840
1841 ;;; File: "asm.scm"
1842 ;;;
1843 ;;; This module implements the generic assembler.
1844
1845 ;;(##declare (standard-bindings) (fixnum) (block))
1846
1847 (define compiler-internal-error error)
1848
1849 ;; (asm-begin! start-pos big-endian?) initializes the assembler and
1850 ;; starts a new empty code stream at address "start-pos".  It must be
1851 ;; called every time a new code stream is to be built.  The argument
1852 ;; "big-endian?" indicates the byte ordering to use for 16, 32 and 64
1853 ;; bit values.  After a call to "asm-begin!" the code stream is built
1854 ;; by calling the following procedures:
1855 ;;
1856 ;;  asm-8            to add an 8 bit integer to the code stream
1857 ;;  asm-16           to add a 16 bit integer to the code stream
1858 ;;  asm-32           to add a 32 bit integer to the code stream
1859 ;;  asm-64           to add a 64 bit integer to the code stream
1860 ;;  asm-float64      to add a 64 bit IEEE float to the code stream
1861 ;;  asm-string       to add a null terminated string to the code stream
1862 ;;  asm-label        to set a label to the current position in the code stream
1863 ;;  asm-align        to add enough zero bytes to force alignment
1864 ;;  asm-origin       to add enough zero bytes to move to a particular address
1865 ;;  asm-at-assembly  to defer code production to assembly time
1866 ;;  asm-listing      to add textual information to the listing
1867
1868 (define (asm-begin! start-pos big-endian?)
1869   (set! asm-start-pos start-pos)
1870   (set! asm-big-endian? big-endian?)
1871   (set! asm-code-stream (asm-make-stream))
1872   #f)
1873
1874 ;; (asm-end!) must be called to finalize the assembler.
1875
1876 (define (asm-end!)
1877   (set! asm-code-stream #f)
1878   #f)
1879
1880 ;; (asm-8 n) adds an 8 bit signed or unsigned integer to the code stream.
1881
1882 (define (asm-8 n)
1883   (asm-code-extend (asm-bits-0-to-7 n)))
1884
1885 ;; (asm-16 n) adds a 16 bit signed or unsigned integer to the code stream.
1886
1887 (define (asm-16 n)
1888   (if asm-big-endian?
1889     (begin (asm-8 (asm-bits-8-and-up n)) (asm-8 n))
1890     (begin (asm-8 n) (asm-8 (asm-bits-8-and-up n)))))
1891
1892 ;; (asm-32 n) adds a 32 bit signed or unsigned integer to the code stream.
1893
1894 (define (asm-32 n)
1895   (if asm-big-endian?
1896     (begin (asm-16 (asm-bits-16-and-up n)) (asm-16 n))
1897     (begin (asm-16 n) (asm-16 (asm-bits-16-and-up n)))))
1898
1899 ;; (asm-64 n) adds a 64 bit signed or unsigned integer to the code stream.
1900
1901 (define (asm-64 n)
1902   (if asm-big-endian?
1903     (begin (asm-32 (asm-bits-32-and-up n)) (asm-32 n))
1904     (begin (asm-32 n) (asm-32 (asm-bits-32-and-up n)))))
1905
1906 ;; (asm-float64 n) adds a 64 bit IEEE floating point number to the code stream.
1907
1908 (define (asm-float64 n)
1909   (asm-64 (asm-float->bits n)))
1910
1911 ;; (asm-string str) adds a null terminated string to the code stream.
1912
1913 (define (asm-string str)
1914   (let ((len (string-length str)))
1915     (let loop ((i 0))
1916       (if (< i len)
1917         (begin
1918           (asm-8 (char->integer (string-ref str i)))
1919           (loop (+ i 1)))
1920         (asm-8 0)))))
1921
1922 ;; (asm-make-label id) creates a new label object.  A label can
1923 ;; be queried with "asm-label-pos" to obtain the label's position
1924 ;; relative to the start of the code stream (i.e. "start-pos").
1925 ;; The argument "id" gives a name to the label (not necessarily
1926 ;; unique) and is only needed for debugging purposes.
1927
1928 (define (asm-make-label id)
1929   (vector 'LABEL #f id))
1930
1931 ;; (asm-label label-obj) sets the label to the current position in the
1932 ;; code stream.
1933
1934 (define (asm-label label-obj)
1935   (if (vector-ref label-obj 1)
1936     (compiler-internal-error
1937       "asm-label, label multiply defined" (asm-label-id label-obj))
1938     (begin
1939       (vector-set! label-obj 1 0)
1940       (asm-code-extend label-obj))))
1941
1942 ;; (asm-label-id label-obj) returns the identifier of the label object.
1943
1944 (define (asm-label-id label-obj)
1945   (vector-ref label-obj 2))
1946
1947 ;; (asm-label-pos label-obj) returns the position of the label
1948 ;; relative to the start of the code stream (i.e. "start-pos").
1949 ;; This procedure can only be called at assembly time (i.e.
1950 ;; within the call to "asm-assemble") or after assembly time
1951 ;; for labels declared prior to assembly time with "asm-label".
1952 ;; A label declared at assembly time can only be queried after
1953 ;; assembly time.  Moreover, at assembly time the position of a
1954 ;; label may vary from one call to the next due to the actions
1955 ;; of the assembler.
1956
1957 (define (asm-label-pos label-obj)
1958   (let ((pos (vector-ref label-obj 1)))
1959     (if pos
1960       pos
1961       (compiler-internal-error
1962         "asm-label-pos, undefined label" (asm-label-id label-obj)))))
1963
1964 ;; (asm-align multiple offset) adds enough zero bytes to the code
1965 ;; stream to force alignment to the next address congruent to
1966 ;; "offset" modulo "multiple".
1967
1968 (define (asm-align multiple offset)
1969   (asm-at-assembly
1970     (lambda (self)
1971       (modulo (- multiple (- self offset)) multiple))
1972     (lambda (self)
1973       (let loop ((n (modulo (- multiple (- self offset)) multiple)))
1974         (if (> n 0)
1975           (begin
1976             (asm-8 0)
1977             (loop (- n 1))))))))
1978
1979 ;; (asm-origin address) adds enough zero bytes to the code stream to move
1980 ;; to the address "address".
1981
1982 (define (asm-origin address)
1983   (asm-at-assembly
1984     (lambda (self)
1985       (- address self))
1986     (lambda (self)
1987       (let ((len (- address self)))
1988         (if (< len 0)
1989           (compiler-internal-error "asm-origin, can't move back")
1990           (let loop ((n len))
1991             (if (> n 0)
1992               (begin
1993                 (asm-8 0)
1994                 (loop (- n 1))))))))))
1995
1996 ;; (asm-at-assembly . procs) makes it possible to defer code
1997 ;; production to assembly time.  A useful application is to generate
1998 ;; position dependent and span dependent code sequences.  This
1999 ;; procedure must be passed an even number of procedures.  All odd
2000 ;; indexed procedures (including the first procedure) are called "check"
2001 ;; procedures.  The even indexed procedures are the "production"
2002 ;; procedures which, when called, produce a particular code sequence.
2003 ;; A check procedure decides if, given the current state of assembly
2004 ;; (in particular the current positioning of the labels), the code
2005 ;; produced by the corresponding production procedure is valid.
2006 ;; If the code is not valid, the check procedure must return #f.
2007 ;; If the code is valid, the check procedure must return the length
2008 ;; of the code sequence in bytes.  The assembler will try each check
2009 ;; procedure in order until it finds one that does not return #f
2010 ;; (the last check procedure must never return #f).  For convenience,
2011 ;; the current position in the code sequence is passed as the single
2012 ;; argument of check and production procedures.
2013 ;;
2014 ;; Here is a sample call of "asm-at-assembly" to produce the
2015 ;; shortest branch instruction to branch to label "x" for a
2016 ;; hypothetical processor:
2017 ;;
2018 ;;  (asm-at-assembly
2019 ;;
2020 ;;    (lambda (self) ; first check procedure
2021 ;;      (let ((dist (- (asm-label-pos x) self)))
2022 ;;        (if (and (>= dist -128) (<= dist 127)) ; short branch possible?
2023 ;;          2
2024 ;;          #f)))
2025 ;;
2026 ;;    (lambda (self) ; first production procedure
2027 ;;      (asm-8 #x34) ; branch opcode for 8 bit displacement
2028 ;;      (asm-8 (- (asm-label-pos x) self)))
2029 ;;
2030 ;;    (lambda (self) 5) ; second check procedure
2031 ;;
2032 ;;    (lambda (self) ; second production procedure
2033 ;;      (asm-8 #x35) ; branch opcode for 32 bit displacement
2034 ;;      (asm-32 (- (asm-label-pos x) self))))
2035
2036 (define (asm-at-assembly . procs)
2037   (asm-code-extend (vector 'DEFERRED procs)))
2038
2039 ;; (asm-listing text) adds text to the right side of the listing.
2040 ;; The atoms in "text" will be output using "display" (lists are
2041 ;; traversed recursively).  The listing is generated by calling
2042 ;; "asm-display-listing".
2043
2044 (define (asm-listing text)
2045   (asm-code-extend (vector 'LISTING text)))
2046
2047 ;; (asm-assemble) assembles the code stream.  After assembly, the
2048 ;; label objects will be set to their final position and the
2049 ;; alignment bytes and the deferred code will have been produced.  It
2050 ;; is possible to extend the code stream after assembly.  However, if
2051 ;; any of the procedures "asm-label", "asm-align", and
2052 ;; "asm-at-assembly" are called, the code stream will have to be
2053 ;; assembled once more.
2054
2055 (define (asm-assemble)
2056   (let ((fixup-lst (asm-pass1)))
2057
2058     (let loop1 ()
2059       (let loop2 ((lst fixup-lst)
2060                   (changed? #f)
2061                   (pos asm-start-pos))
2062         (if (null? lst)
2063           (if changed? (loop1))
2064           (let* ((fixup (car lst))
2065                  (pos (+ pos (car fixup)))
2066                  (curr (cdr fixup))
2067                  (x (car curr)))
2068             (if (eq? (vector-ref x 0) 'LABEL)
2069               ; LABEL
2070               (if (= (vector-ref x 1) pos)
2071                 (loop2 (cdr lst) changed? pos)
2072                 (begin
2073                   (vector-set! x 1 pos)
2074                   (loop2 (cdr lst) #t pos)))
2075               ; DEFERRED
2076               (let loop3 ()
2077                 (let ((n ((car (vector-ref x 1)) pos)))
2078                   (if n
2079                     (loop2 (cdr lst) changed? (+ pos n))
2080                     (begin
2081                       (vector-set! x 1 (cddr (vector-ref x 1)))
2082                       (loop3))))))))))
2083
2084     (let loop4 ((prev asm-code-stream)
2085                 (curr (cdr asm-code-stream))
2086                 (pos asm-start-pos))
2087       (if (null? curr)
2088         (set-car! asm-code-stream prev)
2089         (let ((x (car curr))
2090               (next (cdr curr)))
2091           (if (vector? x)
2092             (let ((kind (vector-ref x 0)))
2093               (cond ((eq? kind 'LABEL)
2094                      (let ((final-pos (vector-ref x 1)))
2095                        (if final-pos
2096                          (if (not (= pos final-pos))
2097                            (compiler-internal-error
2098                              "asm-assemble, inconsistency detected"))
2099                          (vector-set! x 1 pos))
2100                        (set-cdr! prev next)
2101                        (loop4 prev next pos)))
2102                     ((eq? kind 'DEFERRED)
2103                      (let ((temp asm-code-stream))
2104                        (set! asm-code-stream (asm-make-stream))
2105                        ((cadr (vector-ref x 1)) pos)
2106                        (let ((tail (car asm-code-stream)))
2107                          (set-cdr! tail next)
2108                          (let ((head (cdr asm-code-stream)))
2109                            (set-cdr! prev head)
2110                            (set! asm-code-stream temp)
2111                            (loop4 prev head pos)))))
2112                     (else
2113                      (loop4 curr next pos))))
2114             (loop4 curr next (+ pos 1))))))))
2115
2116 ;; (asm-display-listing port) produces a listing of the code stream
2117 ;; on the given output port.  The bytes generated are shown in
2118 ;; hexadecimal on the left side of the listing and the right side
2119 ;; of the listing contains the text inserted by "asm-listing".
2120
2121 (define (asm-display-listing port)
2122
2123   (define text-col 24)
2124   (define pos-width 6)
2125   (define byte-width 2)
2126
2127   (define (output text)
2128     (cond ((null? text))
2129           ((pair? text)
2130            (output (car text))
2131            (output (cdr text)))
2132           (else
2133            (display text port))))
2134
2135   (define (print-hex n)
2136     (display (string-ref "0123456789ABCDEF" n) port))
2137
2138   (define (print-byte n)
2139     (print-hex (quotient n 16))
2140     (print-hex (modulo n 16)))
2141
2142   (define (print-pos n)
2143     (if (< n 0)
2144       (display "      " port)
2145       (begin
2146         (print-byte (quotient n #x10000))
2147         (print-byte (modulo (quotient n #x100) #x100))
2148         (print-byte (modulo n #x100)))))
2149
2150   (let loop1 ((lst (cdr asm-code-stream)) (pos asm-start-pos) (col 0))
2151     (if (null? lst)
2152       (if (> col 0)
2153         (newline port))
2154       (let ((x (car lst)))
2155         (if (vector? x)
2156           (let ((kind (vector-ref x 0)))
2157             (cond ((eq? kind 'LISTING)
2158                    (let loop2 ((col col))
2159                      (if (< col text-col)
2160                        (begin
2161                          (display (integer->char 9) port)
2162                          (loop2 (* 8 (+ (quotient col 8) 1))))))
2163                    (output (vector-ref x 1))
2164                    (newline port)
2165                    (loop1 (cdr lst) pos 0))
2166                   (else
2167                    (compiler-internal-error
2168                      "asm-display-listing, code stream not assembled"))))
2169           (if (or (= col 0) (>= col (- text-col byte-width)))
2170             (begin
2171               (if (not (= col 0)) (newline port))
2172               (print-pos pos)
2173               (display " " port)
2174               (print-byte x)
2175               (loop1 (cdr lst) (+ pos 1) (+ (+ pos-width 1) byte-width)))
2176             (begin
2177               (print-byte x)
2178               (loop1 (cdr lst) (+ pos 1) (+ col byte-width)))))))))
2179
2180 ;; (asm-write-code filename) outputs the code stream (i.e. the sequence
2181 ;; of bytes produced) on the named file.
2182
2183 (define (asm-write-code filename)
2184   (with-output-to-file filename
2185     (lambda ()
2186       (let loop ((lst (cdr asm-code-stream)))
2187         (if (not (null? lst))
2188           (let ((x (car lst)))
2189             (if (vector? x)
2190               (let ((kind (vector-ref x 0)))
2191                 (if (not (eq? kind 'LISTING))
2192                   (compiler-internal-error
2193                     "asm-write-code, code stream not assembled"))
2194                 (loop (cdr lst)))
2195               (begin
2196                 (write-char (integer->char x))
2197                 (loop (cdr lst))))))))))
2198
2199 (define (asm-write-hex-file filename)
2200   (with-output-to-file filename
2201     (lambda ()
2202
2203       (define (print-hex n)
2204         (display (string-ref "0123456789ABCDEF" n)))
2205
2206       (define (print-byte n)
2207         (print-hex (quotient n 16))
2208         (print-hex (modulo n 16)))
2209
2210       (define (print-line type addr bytes)
2211         (let ((n (length bytes))
2212               (addr-hi (quotient addr 256))
2213               (addr-lo (modulo addr 256)))
2214           (display ":")
2215           (print-byte n)
2216           (print-byte addr-hi)
2217           (print-byte addr-lo)
2218           (print-byte type)
2219           (for-each print-byte bytes)
2220           (let ((sum
2221                  (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
2222             (print-byte sum)
2223             (newline))))
2224
2225       (let loop ((lst (cdr asm-code-stream))
2226                  (pos asm-start-pos)
2227                  (rev-bytes '()))
2228         (if (not (null? lst))
2229           (let ((x (car lst)))
2230             (if (vector? x)
2231               (let ((kind (vector-ref x 0)))
2232                 (if (not (eq? kind 'LISTING))
2233                   (compiler-internal-error
2234                     "asm-write-hex-file, code stream not assembled"))
2235                 (loop (cdr lst)
2236                       pos
2237                       rev-bytes))
2238               (let ((new-pos
2239                      (+ pos 1))
2240                     (new-rev-bytes
2241                      (cons x
2242                            (if (= (modulo pos 16) 0)
2243                                (begin
2244                                  (print-line 0
2245                                              (- pos (length rev-bytes))
2246                                              (reverse rev-bytes))
2247                                  '())
2248                                rev-bytes))))
2249                 (loop (cdr lst)
2250                       new-pos
2251                       new-rev-bytes))))
2252           (begin
2253             (if (not (null? rev-bytes))
2254                 (print-line 0
2255                             (- pos (length rev-bytes))
2256                             (reverse rev-bytes)))
2257             (print-line 1 0 '())
2258             (if #t
2259                 (begin
2260                   (display (- pos asm-start-pos) ##stderr-port)
2261                   (display " bytes\n" ##stderr-port)))))))))
2262
2263 ;; Utilities.
2264
2265 (define asm-start-pos #f)   ; start position of the code stream
2266 (define asm-big-endian? #f) ; endianness to use
2267 (define asm-code-stream #f) ; current code stream
2268
2269 (define (asm-make-stream) ; create an empty stream
2270   (let ((x (cons '() '())))
2271     (set-car! x x)
2272     x))
2273
2274 (define (asm-code-extend item) ; add an item at the end of current code stream
2275   (let* ((stream asm-code-stream)
2276          (tail (car stream))
2277          (cell (cons item '())))
2278     (set-cdr! tail cell)
2279     (set-car! stream cell)))
2280
2281 (define (asm-pass1) ; construct fixup list and make first label assignment
2282   (let loop ((curr (cdr asm-code-stream))
2283              (fixup-lst '())
2284              (span 0)
2285              (pos asm-start-pos))
2286     (if (null? curr)
2287       (reverse fixup-lst)
2288       (let ((x (car curr)))
2289         (if (vector? x)
2290           (let ((kind (vector-ref x 0)))
2291             (cond ((eq? kind 'LABEL)
2292                    (vector-set! x 1 pos) ; first approximation of position
2293                    (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos))
2294                   ((eq? kind 'DEFERRED)
2295                    (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos))
2296                   (else
2297                    (loop (cdr curr) fixup-lst span pos))))
2298           (loop (cdr curr) fixup-lst (+ span 1) (+ pos 1)))))))
2299
2300 ;(##declare (generic))
2301
2302 (define (asm-bits-0-to-7 n) ; return bits 0 to 7 of a signed integer
2303   (modulo n #x100))
2304
2305 (define (asm-bits-8-and-up n) ; return bits 8 and up of a signed integer
2306   (if (>= n 0)
2307     (quotient n #x100)
2308     (- (quotient (+ n 1) #x100) 1)))
2309
2310 (define (asm-bits-16-and-up n) ; return bits 16 and up of a signed integer
2311   (if (>= n 0)
2312     (quotient n #x10000)
2313     (- (quotient (+ n 1) #x10000) 1)))
2314
2315 (define (asm-bits-32-and-up n) ; return bits 32 and up of a signed integer
2316   (if (>= n 0)
2317     (quotient n #x100000000)
2318     (- (quotient (+ n 1) #x100000000) 1)))
2319
2320 ; The following procedures convert floating point numbers into their
2321 ; machine representation.  They perform bignum and flonum arithmetic.
2322
2323 (define (asm-float->inexact-exponential-format x)
2324
2325   (define (exp-form-pos x y i)
2326     (let ((i*2 (+ i i)))
2327       (let ((z (if (and (not (< asm-ieee-e-bias i*2))
2328                         (not (< x y)))
2329                  (exp-form-pos x (* y y) i*2)
2330                  (cons x 0))))
2331         (let ((a (car z)) (b (cdr z)))
2332           (let ((i+b (+ i b)))
2333             (if (and (not (< asm-ieee-e-bias i+b))
2334                      (not (< a y)))
2335               (begin
2336                 (set-car! z (/ a y))
2337                 (set-cdr! z i+b)))
2338             z)))))
2339
2340   (define (exp-form-neg x y i)
2341     (let ((i*2 (+ i i)))
2342       (let ((z (if (and (< i*2 asm-ieee-e-bias-minus-1)
2343                         (< x y))
2344                  (exp-form-neg x (* y y) i*2)
2345                  (cons x 0))))
2346         (let ((a (car z)) (b (cdr z)))
2347           (let ((i+b (+ i b)))
2348             (if (and (< i+b asm-ieee-e-bias-minus-1)
2349                      (< a y))
2350               (begin
2351                 (set-car! z (/ a y))
2352                 (set-cdr! z i+b)))
2353             z)))))
2354
2355   (define (exp-form x)
2356     (if (< x asm-inexact-+1)
2357       (let ((z (exp-form-neg x asm-inexact-+1/2 1)))
2358         (set-car! z (* asm-inexact-+2 (car z)))
2359         (set-cdr! z (- -1 (cdr z)))
2360         z)
2361       (exp-form-pos x asm-inexact-+2 1)))
2362
2363   (if (negative? x)
2364     (let ((z (exp-form (- asm-inexact-0 x))))
2365       (set-car! z (- asm-inexact-0 (car z)))
2366       z)
2367     (exp-form x)))
2368
2369 (define (asm-float->exact-exponential-format x)
2370   (let ((z (asm-float->inexact-exponential-format x)))
2371     (let ((y (car z)))
2372       (cond ((not (< y asm-inexact-+2))
2373              (set-car! z asm-ieee-+m-min)
2374              (set-cdr! z asm-ieee-e-bias-plus-1))
2375             ((not (< asm-inexact--2 y))
2376              (set-car! z asm-ieee--m-min)
2377              (set-cdr! z asm-ieee-e-bias-plus-1))
2378             (else
2379              (set-car! z
2380                (truncate (inexact->exact (* (car z) asm-inexact-m-min))))))
2381       (set-cdr! z (- (cdr z) asm-ieee-m-bits))
2382       z)))
2383
2384 (define (asm-float->bits x) ; returns the 64 bit integer encoding the float "x"
2385
2386   (define (bits a b)
2387     (if (< a asm-ieee-+m-min)
2388       a
2389       (+ (- a asm-ieee-+m-min)
2390          (* (+ (+ b asm-ieee-m-bits) asm-ieee-e-bias)
2391             asm-ieee-+m-min))))
2392
2393   (let ((z (asm-float->exact-exponential-format x)))
2394     (let ((a (car z)) (b (cdr z)))
2395       (if (negative? a)
2396         (+ asm-ieee-sign-bit (bits (- 0 a) b))
2397         (bits a b)))))
2398
2399 ; Parameters for ANSI-IEEE Std 754-1985 representation of
2400 ; doubles (i.e. 64 bit floating point numbers):
2401
2402 (define asm-ieee-m-bits 52)
2403 (define asm-ieee-e-bits 11)
2404 (define asm-ieee-+m-min 4503599627370496)    ; (expt 2 asm-ieee-m-bits)
2405 (define asm-ieee--m-min -4503599627370496)   ; (- asm-ieee-+m-min)
2406 (define asm-ieee-sign-bit #x8000000000000000); (expt 2 (+ asm-ieee-e-bits asm-ieee-m-bits))
2407
2408 (define asm-ieee-e-bias         1023) ; (- (expt 2 (- asm-ieee-e-bits 1)) 1)
2409 (define asm-ieee-e-bias-plus-1  1024) ; (+ asm-ieee-e-bias 1)
2410 (define asm-ieee-e-bias-minus-1 1022) ; (- asm-ieee-e-bias 1)
2411
2412 (define asm-inexact-m-min (exact->inexact asm-ieee-+m-min))
2413 (define asm-inexact-+2    (exact->inexact 2))
2414 (define asm-inexact--2    (exact->inexact -2))
2415 (define asm-inexact-+1    (exact->inexact 1))
2416 (define asm-inexact-+1/2  (exact->inexact (/ 1 2)))
2417 (define asm-inexact-0     (exact->inexact 0))
2418
2419 ;------------------------------------------------------------------------------
2420
2421 (define min-fixnum-encoding 3)
2422 (define min-fixnum 0)
2423 (define max-fixnum 255)
2424 (define min-rom-encoding (+ min-fixnum-encoding (- max-fixnum min-fixnum) 1))
2425 (define min-ram-encoding 512)
2426 (define max-ram-encoding 4095)
2427 (define min-vec-encoding 4096)
2428 (define max-vec-encoding 8191)
2429
2430 (define code-start #x5000)
2431
2432 (define (predef-constants) (list))
2433
2434 (define (predef-globals) (list))
2435
2436 (define (encode-direct obj)
2437   (cond ((eq? obj #f)
2438          0)
2439         ((eq? obj #t)
2440          1)
2441         ((eq? obj '())
2442          2)
2443         ((and (integer? obj)
2444               (exact? obj)
2445               (>= obj min-fixnum)
2446               (<= obj max-fixnum))
2447          (+ obj (- min-fixnum-encoding min-fixnum)))
2448         (else
2449          #f)))
2450
2451 (define (translate-constant obj)
2452   (if (char? obj)
2453       (char->integer obj)
2454       obj))
2455
2456 (define (encode-constant obj constants)
2457   (let ((o (translate-constant obj)))
2458     (let ((e (encode-direct o)))
2459       (if e
2460           e
2461           (let ((x (assoc o constants))) ;; TODO was assq
2462             (if x
2463                 (vector-ref (cdr x) 0)
2464                 (compiler-error "unknown object" obj)))))))
2465
2466 (define (add-constant obj constants from-code? cont)
2467   (let ((o (translate-constant obj)))
2468     (let ((e (encode-direct o)))
2469       (if e
2470           (cont constants)
2471           (let ((x (assoc o constants))) ;; TODO was assq
2472             (if x
2473                 (begin
2474                   (if from-code?
2475                       (vector-set! (cdr x) 2 (+ (vector-ref (cdr x) 2) 1)))
2476                   (cont constants))
2477                 (let* ((descr
2478                         (vector #f
2479                                 (asm-make-label 'constant)
2480                                 (if from-code? 1 0)
2481                                 #f))
2482                        (new-constants
2483                         (cons (cons o descr)
2484                               constants)))
2485                   (cond ((pair? o) ;; TODO what to do in the case of a pair of, for example, fixnums, where only one object is actually used ?
2486                          (add-constants (list (car o) (cdr o))
2487                                         new-constants
2488                                         cont))
2489                         ((symbol? o)
2490                          (cont new-constants))
2491                         ((string? o)
2492                          (let ((chars (map char->integer (string->list o))))
2493                            (vector-set! descr 3 chars)
2494                            (add-constant chars
2495                                          new-constants
2496                                          #f
2497                                          cont)))
2498                         ((vector? o)
2499                          (let ((elems (vector->list o)))
2500                            (vector-set! descr 3 elems)
2501                            (add-constant elems
2502                                          new-constants
2503                                          #f
2504                                          cont)))
2505                         ((u8vector? o) ;; NEW, for now they are lists
2506                          (let ((elems (u8vector->list o)))
2507                            (vector-set! descr 3 elems)
2508                            (add-constant elems
2509                                          new-constants
2510                                          #f
2511                                          cont)))
2512                         (else
2513                          (cont new-constants))))))))))
2514
2515 (define (add-constants objs constants cont)
2516   (if (null? objs)
2517       (cont constants)
2518       (add-constant (car objs)
2519                     constants
2520                     #f
2521                     (lambda (new-constants)
2522                       (add-constants (cdr objs)
2523                                      new-constants
2524                                      cont)))))
2525
2526 (define (add-global var globals cont)
2527   (let ((x (assq var globals)))
2528     (if x
2529         (cont globals)
2530         (let ((new-globals
2531                (cons (cons var (length globals))
2532                      globals)))
2533           (cont new-globals)))))
2534
2535 (define (sort-constants constants)
2536   (let ((csts
2537          (sort-list constants
2538                     (lambda (x y)
2539                       (> (vector-ref (cdr x) 2)
2540                          (vector-ref (cdr y) 2))))))
2541     (let loop ((i min-rom-encoding)
2542                (lst csts))
2543       (if (null? lst)
2544           (if (> i min-ram-encoding)
2545               (compiler-error "too many constants")
2546               csts)
2547           (begin
2548             (vector-set! (cdr (car lst)) 0 i)
2549             (loop (+ i 1)
2550                   (cdr lst)))))))
2551
2552 (define assemble
2553   (lambda (code hex-filename)
2554     (let loop1 ((lst code)
2555                 (constants (predef-constants))
2556                 (globals (predef-globals))
2557                 (labels (list)))
2558       (if (pair? lst)
2559
2560           (let ((instr (car lst)))
2561             (cond ((number? instr)
2562                    (loop1 (cdr lst)
2563                           constants
2564                           globals
2565                           (cons (cons instr (asm-make-label 'label))
2566                                 labels)))
2567                   ((eq? (car instr) 'push-constant)
2568                    (add-constant (cadr instr)
2569                                  constants
2570                                  #t
2571                                  (lambda (new-constants)
2572                                    (loop1 (cdr lst)
2573                                           new-constants
2574                                           globals
2575                                           labels))))
2576                   ((memq (car instr) '(push-global set-global))
2577                    (add-global (cadr instr)
2578                                globals
2579                                (lambda (new-globals)
2580                                  (loop1 (cdr lst)
2581                                         constants
2582                                         new-globals
2583                                         labels))))
2584                   (else
2585                    (loop1 (cdr lst)
2586                           constants
2587                           globals
2588                           labels))))
2589
2590           (let ((constants (sort-constants constants)))
2591
2592             (define (label-instr label opcode)
2593               (asm-at-assembly
2594                (lambda (self)
2595                  3)
2596                (lambda (self)
2597                  (let ((pos (- (asm-label-pos label) code-start)))
2598                    (asm-8 opcode)
2599                    (asm-8 (quotient pos 256))
2600                    (asm-8 (modulo pos 256))))))
2601
2602             (define (push-constant n)
2603               (if (<= n 31)
2604                   (asm-8 (+ #x00 n))
2605                   (begin
2606                     (asm-8 #xfc)
2607                     (asm-8 (quotient n 256)) ;; BREGG this is a test, the compiler cannot know about anything over 256 (as long as no rom goes higher, which might change, watch out for this), so no need for 13 bits OOPS, actually, 8 is not enough for fixnums and rom, revert to 12 and use some of the free instrs ?
2608                     (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
2609
2610             (define (push-stack n)
2611               (if (> n 31)
2612                   (compiler-error "stack is too deep")
2613                   (asm-8 (+ #x20 n))))
2614
2615             (define (push-global n)
2616               (asm-8 (+ #x40 n)) ;; TODO maybe do the same as for csts, have a push-long-global to have more ?
2617               ;; (if (> n 15)
2618               ;;     (compiler-error "too many global variables")
2619               ;;     (asm-8 (+ #x40 n)))
2620               ) ;; TODO actually inline most, or put as csts
2621
2622             (define (set-global n)
2623               (asm-8 (+ #x50 n))
2624               ;; (if (> n 15) ;; ADDED prevented the stack from compiling
2625               ;;     (compiler-error "too many global variables")
2626               ;;     (asm-8 (+ #x50 n)))
2627               )
2628
2629             (define (call n)
2630               (if (> n 15)
2631                   (compiler-error "call has too many arguments")
2632                   (asm-8 (+ #x60 n))))
2633
2634             (define (jump n)
2635               (if (> n 15)
2636                   (compiler-error "call has too many arguments")
2637                   (asm-8 (+ #x70 n))))
2638
2639             (define (call-toplevel label) ;; TODO use 8-bit opcodes for these
2640               (label-instr label #x80))
2641
2642             (define (jump-toplevel label)
2643               (label-instr label #x90))
2644
2645             (define (goto label)
2646               (label-instr label #xa0))
2647
2648             (define (goto-if-false label)
2649               (label-instr label #xb0))
2650
2651             (define (closure label)
2652               (label-instr label #xc0)) ;; FOOBAR change here ?
2653
2654             (define (prim n)
2655               (asm-8 (+ #xd0 n)))
2656
2657             (define (prim.number?)         (prim 0))
2658             (define (prim.+)               (prim 1))
2659             (define (prim.-)               (prim 2))
2660             (define (prim.*)               (prim 3))
2661             (define (prim.quotient)        (prim 4))
2662             (define (prim.remainder)       (prim 5))
2663             (define (prim.neg)             (prim 6))
2664             (define (prim.=)               (prim 7))
2665             (define (prim.<)               (prim 8))
2666             (define (prim.ior)             (prim 9))
2667             (define (prim.>)               (prim 10))
2668             (define (prim.xor)             (prim 11))
2669             (define (prim.pair?)           (prim 12))
2670             (define (prim.cons)            (prim 13))
2671             (define (prim.car)             (prim 14))
2672             (define (prim.cdr)             (prim 15))
2673             (define (prim.set-car!)        (prim 16))
2674             (define (prim.set-cdr!)        (prim 17))
2675             (define (prim.null?)           (prim 18))
2676             (define (prim.eq?)             (prim 19))
2677             (define (prim.not)             (prim 20))
2678             (define (prim.get-cont)        (prim 21))
2679             (define (prim.graft-to-cont)   (prim 22))
2680             (define (prim.return-to-cont)  (prim 23))
2681             (define (prim.halt)            (prim 24))
2682             (define (prim.symbol?)         (prim 25))
2683             (define (prim.string?)         (prim 26))
2684             (define (prim.string->list)    (prim 27))
2685             (define (prim.list->string)    (prim 28))
2686
2687             (define (prim.make-u8vector)   (prim 29))
2688             (define (prim.u8vector-ref)    (prim 30))
2689             (define (prim.u8vector-set!)   (prim 31))
2690
2691             (define (prim.print)           (prim 32))
2692             (define (prim.clock)           (prim 33))
2693             (define (prim.motor)           (prim 34))
2694             (define (prim.led)             (prim 35))
2695             (define (prim.led2-color)      (prim 36))
2696             (define (prim.getchar-wait)    (prim 37))
2697             (define (prim.putchar)         (prim 38))
2698             (define (prim.beep)            (prim 39))
2699             (define (prim.adc)             (prim 40))
2700             (define (prim.u8vector?)       (prim 41)) ;; TODO was dac
2701             (define (prim.sernum)          (prim 42)) ;; TODO necessary ?
2702             (define (prim.u8vector-length) (prim 43))
2703
2704             (define (prim.shift)           (prim 45))
2705             (define (prim.pop)             (prim 46))
2706             (define (prim.return)          (prim 47))
2707
2708             (define big-endian? #f)
2709
2710             (asm-begin! code-start #f)
2711
2712             (asm-8 #xfb)
2713             (asm-8 #xd7)
2714             (asm-8 (length constants))
2715             (asm-8 0)
2716
2717             (pp (list constants: constants globals: globals)) ;; TODO debug
2718
2719             (for-each
2720              (lambda (x)
2721                (let* ((descr (cdr x))
2722                       (label (vector-ref descr 1))
2723                       (obj (car x)))
2724                  (asm-label label)
2725                  ;; see the vm source for a description of encodings
2726                  (cond ((and (integer? obj) (exact? obj))
2727                         (asm-8 0)
2728                         (asm-8 (bitwise-and (arithmetic-shift obj -16) 255))
2729                         (asm-8 (bitwise-and (arithmetic-shift obj -8) 255))
2730                         (asm-8 (bitwise-and obj 255)))
2731                        ((pair? obj)
2732                         (let ((obj-car (encode-constant (car obj) constants))
2733                               (obj-cdr (encode-constant (cdr obj) constants)))
2734                           (asm-8 (+ #x80 (arithmetic-shift obj-car -8)))
2735                           (asm-8 (bitwise-and obj-car #xff))
2736                           (asm-8 (+ 0 (arithmetic-shift obj-cdr -8)))
2737                           (asm-8 (bitwise-and obj-cdr #xff))))
2738                        ((symbol? obj)
2739                         (asm-8 #x80)
2740                         (asm-8 0)
2741                         (asm-8 #x20)
2742                         (asm-8 0))
2743                        ((string? obj)
2744                         (let ((obj-enc (encode-constant (vector-ref descr 3)
2745                                                         constants)))
2746                           (asm-8 (+ #x80 (arithmetic-shift obj-enc -8)))
2747                           (asm-8 (bitwise-and obj-enc #xff))
2748                           (asm-8 #x40)
2749                           (asm-8 0)))
2750                        ((vector? obj) ;; BREGG change this, we have no ordinary vectors
2751                         ;; TODO this is the OLD representation, NOT GOOD (but not used) BREGG
2752                         (let ((obj-enc (encode-constant (vector-ref descr 3)
2753                                                         constants)))
2754                           (asm-8 (+ #x80 (arithmetic-shift obj-enc -8)))
2755                           (asm-8 (bitwise-and obj-enc #xff))
2756                           (asm-8 #x60)
2757                           (asm-8 0)))
2758                        ((u8vector? obj) ;; NEW, lists for now (internal representation same as ordinary vectors, who don't actually exist)
2759                         (let ((obj-enc (encode-constant (vector-ref descr 3)
2760                                                         constants))
2761                               (l (length (vector-ref descr 3))))
2762                           (asm-8 (+ #x80 (arithmetic-shift l -8)))
2763                           (asm-8 (bitwise-and l #xff))
2764                           (asm-8 (+ #x60 (arithmetic-shift obj-enc -8)))
2765                           (asm-8 (bitwise-and obj-enc #xff))))
2766                        (else
2767                         (compiler-error "unknown object type" obj)))))
2768              constants)
2769
2770             (let loop2 ((lst code))
2771               (if (pair? lst)
2772                   (let ((instr (car lst)))
2773
2774                     (cond ((number? instr)
2775                            (let ((label (cdr (assq instr labels))))
2776                              (asm-label label)))
2777
2778                           ((eq? (car instr) 'entry)
2779                            (let ((np (cadr instr))
2780                                  (rest? (caddr instr)))
2781                              (asm-8 (if rest? (- np) np))))
2782
2783                           ((eq? (car instr) 'push-constant) ;; TODO FOOBAR 12 bits for constants now (actually, I don't think it matters here)
2784                            (let ((n (encode-constant (cadr instr) constants)))
2785                              (push-constant n)))
2786
2787                           ((eq? (car instr) 'push-stack)
2788                            (push-stack (cadr instr)))
2789
2790                           ((eq? (car instr) 'push-global)
2791                            (push-global (cdr (assq (cadr instr) globals))))
2792
2793                           ((eq? (car instr) 'set-global)
2794                            (set-global (cdr (assq (cadr instr) globals))))
2795
2796                           ((eq? (car instr) 'call)
2797                            (call (cadr instr)))
2798
2799                           ((eq? (car instr) 'jump)
2800                            (jump (cadr instr)))
2801
2802                           ((eq? (car instr) 'call-toplevel)
2803                            (let ((label (cdr (assq (cadr instr) labels))))
2804                              (call-toplevel label)))
2805
2806                           ((eq? (car instr) 'jump-toplevel)
2807                            (let ((label (cdr (assq (cadr instr) labels))))
2808                              (jump-toplevel label)))
2809
2810                           ((eq? (car instr) 'goto)
2811                            (let ((label (cdr (assq (cadr instr) labels))))
2812                              (goto label)))
2813
2814                           ((eq? (car instr) 'goto-if-false)
2815                            (let ((label (cdr (assq (cadr instr) labels))))
2816                              (goto-if-false label)))
2817
2818                           ((eq? (car instr) 'closure)
2819                            (let ((label (cdr (assq (cadr instr) labels))))
2820                              (closure label)))
2821
2822                           ((eq? (car instr) 'prim)
2823                            (case (cadr instr)
2824                              ((#%number?)         (prim.number?))
2825                              ((#%+)               (prim.+))
2826                              ((#%-)               (prim.-))
2827                              ((#%*)               (prim.*))
2828                              ((#%quotient)        (prim.quotient))
2829                              ((#%remainder)       (prim.remainder))
2830                              ((#%neg)             (prim.neg))
2831                              ((#%=)               (prim.=))
2832                              ((#%<)               (prim.<))
2833                              ((#%ior)             (prim.ior))
2834                              ((#%>)               (prim.>))
2835                              ((#%xor)             (prim.xor))
2836                              ((#%pair?)           (prim.pair?))
2837                              ((#%cons)            (prim.cons))
2838                              ((#%car)             (prim.car))
2839                              ((#%cdr)             (prim.cdr))
2840                              ((#%set-car!)        (prim.set-car!))
2841                              ((#%set-cdr!)        (prim.set-cdr!))
2842                              ((#%null?)           (prim.null?))
2843                              ((#%eq?)             (prim.eq?))
2844                              ((#%not)             (prim.not))
2845                              ((#%get-cont)        (prim.get-cont))
2846                              ((#%graft-to-cont)   (prim.graft-to-cont))
2847                              ((#%return-to-cont)  (prim.return-to-cont))
2848                              ((#%halt)            (prim.halt))
2849                              ((#%symbol?)         (prim.symbol?))
2850                              ((#%string?)         (prim.string?))
2851                              ((#%string->list)    (prim.string->list))
2852                              ((#%list->string)    (prim.list->string))
2853                              ((#%make-u8vector)   (prim.make-u8vector))
2854                              ((#%u8vector-ref)    (prim.u8vector-ref))
2855                              ((#%u8vector-set!)   (prim.u8vector-set!))
2856
2857                              ((#%print)           (prim.print))
2858                              ((#%clock)           (prim.clock))
2859                              ((#%motor)           (prim.motor))
2860                              ((#%led)             (prim.led))
2861                              ((#%led2-color)      (prim.led2-color))
2862                              ((#%getchar-wait )   (prim.getchar-wait))
2863                              ((#%putchar)         (prim.putchar))
2864                              ((#%beep)            (prim.beep))
2865                              ((#%adc)             (prim.adc))
2866                              ((#%u8vector?)       (prim.u8vector?)) ;; TODO was dac
2867                              ((#%sernum)          (prim.sernum))
2868                              ((#%u8vector-length) (prim.u8vector-length))
2869                              (else
2870                               (compiler-error "unknown primitive" (cadr instr)))))
2871
2872                           ((eq? (car instr) 'return)
2873                            (prim.return))
2874
2875                           ((eq? (car instr) 'pop)
2876                            (prim.pop))
2877
2878                           ((eq? (car instr) 'shift)
2879                            (prim.shift))
2880
2881                           (else
2882                            (compiler-error "unknown instruction" instr)))
2883
2884                     (loop2 (cdr lst)))))
2885
2886             (asm-assemble)
2887
2888             (asm-write-hex-file hex-filename)
2889
2890             (asm-end!))))))
2891
2892 (define execute
2893   (lambda (hex-filename)
2894 '
2895     (if #f
2896         (begin
2897           (shell-command "gcc -o picobit-vm picobit-vm.c")
2898           (shell-command (string-append "./picobit-vm " hex-filename)))
2899         (shell-command (string-append "./robot . 1 " hex-filename)))))
2900
2901 (define (sort-list l <?)
2902
2903   (define (mergesort l)
2904
2905     (define (merge l1 l2)
2906       (cond ((null? l1) l2)
2907             ((null? l2) l1)
2908             (else
2909              (let ((e1 (car l1)) (e2 (car l2)))
2910                (if (<? e1 e2)
2911                  (cons e1 (merge (cdr l1) l2))
2912                  (cons e2 (merge l1 (cdr l2))))))))
2913
2914     (define (split l)
2915       (if (or (null? l) (null? (cdr l)))
2916         l
2917         (cons (car l) (split (cddr l)))))
2918
2919     (if (or (null? l) (null? (cdr l)))
2920       l
2921       (let* ((l1 (mergesort (split l)))
2922              (l2 (mergesort (split (cdr l)))))
2923         (merge l1 l2))))
2924
2925   (mergesort l))
2926
2927 ;------------------------------------------------------------------------------
2928
2929 (define compile
2930   (lambda (filename)
2931     (let* ((node (parse-file filename))
2932            (hex-filename
2933             (string-append
2934              (path-strip-extension filename)
2935              ".hex")))
2936
2937 ;      (pp (node->expr node))
2938
2939       (let ((ctx (comp-none node (make-init-context))))
2940         (let ((prog (linearize (optimize-code (context-code ctx)))))
2941 ;         (pp (list code: prog env: (context-env ctx)))
2942           (assemble prog hex-filename)
2943           (execute hex-filename))))))
2944
2945
2946 (define main
2947   (lambda (filename)
2948     (compile filename)))
2949
2950 ;------------------------------------------------------------------------------
2951
2952 '
2953 (define (asm-write-hex-file filename)
2954   (with-output-to-file filename
2955     (lambda ()
2956
2957       (define (print-hex n)
2958         (display (string-ref "0123456789ABCDEF" n)))
2959
2960       (define (print-byte n)
2961         (display ", 0x")
2962         (print-hex (quotient n 16))
2963         (print-hex (modulo n 16)))
2964
2965       (define (print-line type addr bytes)
2966         (let ((n (length bytes))
2967               (addr-hi (quotient addr 256))
2968               (addr-lo (modulo addr 256)))
2969 ;          (display ":")
2970 ;          (print-byte n)
2971 ;          (print-byte addr-hi)
2972 ;          (print-byte addr-lo)
2973 ;          (print-byte type)
2974           (for-each print-byte bytes)
2975           (let ((sum
2976                  (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
2977 ;            (print-byte sum)
2978             (newline))))
2979
2980       (let loop ((lst (cdr asm-code-stream))
2981                  (pos asm-start-pos)
2982                  (rev-bytes '()))
2983         (if (not (null? lst))
2984           (let ((x (car lst)))
2985             (if (vector? x)
2986               (let ((kind (vector-ref x 0)))
2987                 (if (not (eq? kind 'LISTING))
2988                   (compiler-internal-error
2989                     "asm-write-hex-file, code stream not assembled"))
2990                 (loop (cdr lst)
2991                       pos
2992                       rev-bytes))
2993               (let ((new-pos
2994                      (+ pos 1))
2995                     (new-rev-bytes
2996                      (cons x
2997                            (if (= (modulo pos 8) 0)
2998                                (begin
2999                                  (print-line 0
3000                                              (- pos (length rev-bytes))
3001                                              (reverse rev-bytes))
3002                                  '())
3003                                rev-bytes))))
3004                 (loop (cdr lst)
3005                       new-pos
3006                       new-rev-bytes))))
3007           (begin
3008             (if (not (null? rev-bytes))
3009                 (print-line 0
3010                             (- pos (length rev-bytes))
3011                             (reverse rev-bytes)))
3012             (print-line 1 0 '())))))))