module/language/tree-il/compile-glil.scm

   1 ;;; TREE-IL -> GLIL compiler
   2
   3 ;; Copyright (C) 2001,2008,2009,2010 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (language tree-il compile-glil)
  22   #:use-module (system base syntax)
  23   #:use-module (system base pmatch)
  24   #:use-module (system base message)
  25   #:use-module (ice-9 receive)
  26   #:use-module (language glil)
  27   #:use-module (system vm instruction)
  28   #:use-module (language tree-il)
  29   #:use-module (language tree-il optimize)
  30   #:use-module (language tree-il analyze)
  31   #:use-module ((srfi srfi-1) #:select (filter-map))
  32   #:export (compile-glil))
  33
  34 ;; allocation:
  35 ;;  sym -> {lambda -> address}
  36 ;;  lambda -> (labels . free-locs)
  37 ;;  lambda-case -> (gensym . nlocs)
  38 ;;
  39 ;; address ::= (local? boxed? . index)
  40 ;; labels ::= ((sym . lambda) ...)
  41 ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
  42 ;; free variable addresses are relative to parent proc.
  43
  44 (define *comp-module* (make-fluid))
  45
  46 (define %warning-passes
  47   `((unused-variable     . ,unused-variable-analysis)
  48     (unused-toplevel     . ,unused-toplevel-analysis)
  49     (unbound-variable    . ,unbound-variable-analysis)
  50     (arity-mismatch      . ,arity-analysis)))
  51
  52 (define (compile-glil x e opts)
  53   (define warnings
  54     (or (and=> (memq #:warnings opts) cadr)
  55         '()))
  56
  57   ;; Go through the warning passes.
  58   (let ((analyses (filter-map (lambda (kind)
  59                                 (assoc-ref %warning-passes kind))
  60                               warnings)))
  61     (analyze-tree analyses x e))
  62
  63   (let* ((x (make-lambda (tree-il-src x) '()
  64                          (make-lambda-case #f '() #f #f #f '() '() x #f)))
  65          (x (optimize! x e opts))
  66          (allocation (analyze-lexicals x)))
  67
  68     (with-fluid* *comp-module* e
  69       (lambda ()
  70         (values (flatten-lambda x #f allocation)
  71                 e
  72                 e)))))
  73
  74 \f
  75
  76 (define *primcall-ops* (make-hash-table))
  77 (for-each
  78  (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
  79  '(((eq? . 2) . eq?)
  80    ((eqv? . 2) . eqv?)
  81    ((equal? . 2) . equal?)
  82    ((= . 2) . ee?)
  83    ((< . 2) . lt?)
  84    ((> . 2) . gt?)
  85    ((<= . 2) . le?)
  86    ((>= . 2) . ge?)
  87    ((+ . 2) . add)
  88    ((- . 2) . sub)
  89    ((1+ . 1) . add1)
  90    ((1- . 1) . sub1)
  91    ((* . 2) . mul)
  92    ((/ . 2) . div)
  93    ((quotient . 2) . quo)
  94    ((remainder . 2) . rem)
  95    ((modulo . 2) . mod)
  96    ((ash . 2) . ash)
  97    ((logand . 2) . logand)
  98    ((logior . 2) . logior)
  99    ((logxor . 2) . logxor)
 100    ((not . 1) . not)
 101    ((pair? . 1) . pair?)
 102    ((cons . 2) . cons)
 103    ((car . 1) . car)
 104    ((cdr . 1) . cdr)
 105    ((set-car! . 2) . set-car!)
 106    ((set-cdr! . 2) . set-cdr!)
 107    ((null? . 1) . null?)
 108    ((list? . 1) . list?)
 109    (list . list)
 110    (vector . vector)
 111    ((class-of . 1) . class-of)
 112    ((@slot-ref . 2) . slot-ref)
 113    ((@slot-set! . 3) . slot-set)
 114    ((vector-ref . 2) . vector-ref)
 115    ((vector-set! . 3) . vector-set)
 116    ((variable-ref . 1) . variable-ref)
 117    ;; nb, *not* variable-set! -- the args are switched
 118    ((variable-set . 2) . variable-set)
 119    ((struct? . 1) . struct?)
 120    ((struct-vtable . 1) . struct-vtable)
 121    ((struct-ref . 2) . struct-ref)
 122    ((struct-set! . 3) . struct-set)
 123    (make-struct . make-struct)
 124
 125    ;; hack for javascript
 126    ((return . 1) return)
 127
 128    ((bytevector-u8-ref . 2) . bv-u8-ref)
 129    ((bytevector-u8-set! . 3) . bv-u8-set)
 130    ((bytevector-s8-ref . 2) . bv-s8-ref)
 131    ((bytevector-s8-set! . 3) . bv-s8-set)
 132
 133    ((bytevector-u16-ref . 3) . bv-u16-ref)
 134    ((bytevector-u16-set! . 4) . bv-u16-set)
 135    ((bytevector-u16-native-ref . 2) . bv-u16-native-ref)
 136    ((bytevector-u16-native-set! . 3) . bv-u16-native-set)
 137    ((bytevector-s16-ref . 3) . bv-s16-ref)
 138    ((bytevector-s16-set! . 4) . bv-s16-set)
 139    ((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
 140    ((bytevector-s16-native-set! . 3) . bv-s16-native-set)
 141
 142    ((bytevector-u32-ref . 3) . bv-u32-ref)
 143    ((bytevector-u32-set! . 4) . bv-u32-set)
 144    ((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
 145    ((bytevector-u32-native-set! . 3) . bv-u32-native-set)
 146    ((bytevector-s32-ref . 3) . bv-s32-ref)
 147    ((bytevector-s32-set! . 4) . bv-s32-set)
 148    ((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
 149    ((bytevector-s32-native-set! . 3) . bv-s32-native-set)
 150
 151    ((bytevector-u64-ref . 3) . bv-u64-ref)
 152    ((bytevector-u64-set! . 4) . bv-u64-set)
 153    ((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
 154    ((bytevector-u64-native-set! . 3) . bv-u64-native-set)
 155    ((bytevector-s64-ref . 3) . bv-s64-ref)
 156    ((bytevector-s64-set! . 4) . bv-s64-set)
 157    ((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
 158    ((bytevector-s64-native-set! . 3) . bv-s64-native-set)
 159
 160    ((bytevector-ieee-single-ref . 3) . bv-f32-ref)
 161    ((bytevector-ieee-single-set! . 4) . bv-f32-set)
 162    ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
 163    ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set)
 164    ((bytevector-ieee-double-ref . 3) . bv-f64-ref)
 165    ((bytevector-ieee-double-set! . 4) . bv-f64-set)
 166    ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref)
 167    ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set)))
 168
 169
 170 \f
 171
 172 (define (make-label) (gensym ":L"))
 173
 174 (define (vars->bind-list ids vars allocation proc)
 175   (map (lambda (id v)
 176          (pmatch (hashq-ref (hashq-ref allocation v) proc)
 177            ((#t ,boxed? . ,n)
 178             (list id boxed? n))
 179            (,x (error "badness" id v x))))
 180        ids
 181        vars))
 182
 183 (define (emit-bindings src ids vars allocation proc emit-code)
 184   (emit-code src (make-glil-bind
 185                   (vars->bind-list ids vars allocation proc))))
 186
 187 (define (with-output-to-code proc)
 188   (let ((out '()))
 189     (define (emit-code src x)
 190       (set! out (cons x out))
 191       (if src
 192           (set! out (cons (make-glil-source src) out))))
 193     (proc emit-code)
 194     (reverse out)))
 195
 196 (define (flatten-lambda x self-label allocation)
 197   (record-case x
 198     ((<lambda> src meta body)
 199      (make-glil-program
 200       meta
 201       (with-output-to-code
 202        (lambda (emit-code)
 203          ;; write source info for proc
 204          (if src (emit-code #f (make-glil-source src)))
 205          ;; emit pre-prelude label for self tail calls in which the
 206          ;; number of arguments doesn't check out at compile time
 207          (if self-label
 208              (emit-code #f (make-glil-label self-label)))
 209          ;; compile the body, yo
 210          (flatten body allocation x self-label (car (hashq-ref allocation x))
 211                   emit-code)))))))
 212
 213 (define (flatten x allocation self self-label fix-labels emit-code)
 214   (define (emit-label label)
 215     (emit-code #f (make-glil-label label)))
 216   (define (emit-branch src inst label)
 217     (emit-code src (make-glil-branch inst label)))
 218
 219   ;; RA: "return address"; #f unless we're in a non-tail fix with labels
 220   ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
 221   (let comp ((x x) (context 'tail) (RA #f) (MVRA #f))
 222     (define (comp-tail tree) (comp tree context RA MVRA))
 223     (define (comp-push tree) (comp tree 'push #f #f))
 224     (define (comp-drop tree) (comp tree 'drop #f #f))
 225     (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
 226     (define (comp-fix tree RA) (comp tree context RA MVRA))
 227
 228     ;; A couple of helpers. Note that if we are in tail context, we
 229     ;; won't have an RA.
 230     (define (maybe-emit-return)
 231       (if RA
 232           (emit-branch #f 'br RA)
 233           (if (eq? context 'tail)
 234               (emit-code #f (make-glil-call 'return 1)))))
 235
 236     (record-case x
 237       ((<void>)
 238        (case context
 239          ((push vals tail)
 240           (emit-code #f (make-glil-void))))
 241        (maybe-emit-return))
 242
 243       ((<const> src exp)
 244        (case context
 245          ((push vals tail)
 246           (emit-code src (make-glil-const exp))))
 247        (maybe-emit-return))
 248
 249       ;; FIXME: should represent sequence as exps tail
 250       ((<sequence> exps)
 251        (let lp ((exps exps))
 252          (if (null? (cdr exps))
 253              (comp-tail (car exps))
 254              (begin
 255                (comp-drop (car exps))
 256                (lp (cdr exps))))))
 257
 258       ((<application> src proc args)
 259        ;; FIXME: need a better pattern-matcher here
 260        (cond
 261         ((and (primitive-ref? proc)
 262               (eq? (primitive-ref-name proc) '@apply)
 263               (>= (length args) 1))
 264          (let ((proc (car args))
 265                (args (cdr args)))
 266            (cond
 267             ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
 268                   (not (eq? context 'push)) (not (eq? context 'vals)))
 269              ;; tail: (lambda () (apply values '(1 2)))
 270              ;; drop: (lambda () (apply values '(1 2)) 3)
 271              ;; push: (lambda () (list (apply values '(10 12)) 1))
 272              (case context
 273                ((drop) (for-each comp-drop args) (maybe-emit-return))
 274                ((tail)
 275                 (for-each comp-push args)
 276                 (emit-code src (make-glil-call 'return/values* (length args))))))
 277
 278             (else
 279              (case context
 280                ((tail)
 281                 (comp-push proc)
 282                 (for-each comp-push args)
 283                 (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
 284                ((push)
 285                 (emit-code src (make-glil-call 'new-frame 0))
 286                 (comp-push proc)
 287                 (for-each comp-push args)
 288                 (emit-code src (make-glil-call 'apply (1+ (length args))))
 289                 (maybe-emit-return))
 290                ((vals)
 291                 (comp-vals
 292                  (make-application src (make-primitive-ref #f 'apply)
 293                                    (cons proc args))
 294                  MVRA)
 295                 (maybe-emit-return))
 296                ((drop)
 297                 ;; Well, shit. The proc might return any number of
 298                 ;; values (including 0), since it's in a drop context,
 299                 ;; yet apply does not create a MV continuation. So we
 300                 ;; mv-call out to our trampoline instead.
 301                 (comp-drop
 302                  (make-application src (make-primitive-ref #f 'apply)
 303                                    (cons proc args)))
 304                 (maybe-emit-return)))))))
 305
 306         ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
 307               (not (eq? context 'push)))
 308          ;; tail: (lambda () (values '(1 2)))
 309          ;; drop: (lambda () (values '(1 2)) 3)
 310          ;; push: (lambda () (list (values '(10 12)) 1))
 311          ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
 312          (case context
 313            ((drop) (for-each comp-drop args) (maybe-emit-return))
 314            ((vals)
 315             (for-each comp-push args)
 316             (emit-code #f (make-glil-const (length args)))
 317             (emit-branch src 'br MVRA))
 318            ((tail)
 319             (for-each comp-push args)
 320             (emit-code src (make-glil-call 'return/values (length args))))))
 321
 322         ((and (primitive-ref? proc)
 323               (eq? (primitive-ref-name proc) '@call-with-values)
 324               (= (length args) 2))
 325          ;; CONSUMER
 326          ;; PRODUCER
 327          ;; (mv-call MV)
 328          ;; ([tail]-call 1)
 329          ;; goto POST
 330          ;; MV: [tail-]call/nargs
 331          ;; POST: (maybe-drop)
 332          (case context
 333            ((vals)
 334             ;; Fall back.
 335             (comp-vals
 336              (make-application src (make-primitive-ref #f 'call-with-values)
 337                                args)
 338              MVRA)
 339             (maybe-emit-return))
 340            (else
 341             (let ((MV (make-label)) (POST (make-label))
 342                   (producer (car args)) (consumer (cadr args)))
 343               (if (not (eq? context 'tail))
 344                   (emit-code src (make-glil-call 'new-frame 0)))
 345               (comp-push consumer)
 346               (emit-code src (make-glil-call 'new-frame 0))
 347               (comp-push producer)
 348               (emit-code src (make-glil-mv-call 0 MV))
 349               (case context
 350                 ((tail) (emit-code src (make-glil-call 'tail-call 1)))
 351                 (else   (emit-code src (make-glil-call 'call 1))
 352                         (emit-branch #f 'br POST)))
 353               (emit-label MV)
 354               (case context
 355                 ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
 356                 (else   (emit-code src (make-glil-call 'call/nargs 0))
 357                         (emit-label POST)
 358                         (if (eq? context 'drop)
 359                             (emit-code #f (make-glil-call 'drop 1)))
 360                         (maybe-emit-return)))))))
 361
 362         ((and (primitive-ref? proc)
 363               (eq? (primitive-ref-name proc) '@call-with-current-continuation)
 364               (= (length args) 1))
 365          (case context
 366            ((tail)
 367             (comp-push (car args))
 368             (emit-code src (make-glil-call 'tail-call/cc 1)))
 369            ((vals)
 370             (comp-vals
 371              (make-application
 372               src (make-primitive-ref #f 'call-with-current-continuation)
 373               args)
 374              MVRA)
 375             (maybe-emit-return))
 376            ((push)
 377             (comp-push (car args))
 378             (emit-code src (make-glil-call 'call/cc 1))
 379             (maybe-emit-return))
 380            ((drop)
 381             ;; Crap. Just like `apply' in drop context.
 382             (comp-drop
 383              (make-application
 384               src (make-primitive-ref #f 'call-with-current-continuation)
 385               args))
 386             (maybe-emit-return))))
 387
 388         ((and (primitive-ref? proc)
 389               (or (hash-ref *primcall-ops*
 390                             (cons (primitive-ref-name proc) (length args)))
 391                   (hash-ref *primcall-ops* (primitive-ref-name proc))))
 392          => (lambda (op)
 393               (for-each comp-push args)
 394               (emit-code src (make-glil-call op (length args)))
 395               (case (instruction-pushes op)
 396                 ((0)
 397                  (case context
 398                    ((tail push vals) (emit-code #f (make-glil-void))))
 399                  (maybe-emit-return))
 400                 ((1)
 401                  (case context
 402                    ((drop) (emit-code #f (make-glil-call 'drop 1))))
 403                  (maybe-emit-return))
 404                 (else
 405                  (error "bad primitive op: too many pushes"
 406                         op (instruction-pushes op))))))
 407
 408         ;; self-call in tail position
 409         ((and (lexical-ref? proc)
 410               self-label (eq? (lexical-ref-gensym proc) self-label)
 411               (eq? context 'tail))
 412          ;; first, evaluate new values, pushing them on the stack
 413          (for-each comp-push args)
 414          (let lp ((lcase (lambda-body self)))
 415            (cond
 416             ((and (lambda-case? lcase)
 417                   (not (lambda-case-kw lcase))
 418                   (not (lambda-case-opt lcase))
 419                   (not (lambda-case-rest lcase))
 420                   (= (length args) (length (lambda-case-req lcase))))
 421              ;; we have a case that matches the args; rename variables
 422              ;; and goto the case label
 423              (for-each (lambda (sym)
 424                          (pmatch (hashq-ref (hashq-ref allocation sym) self)
 425                            ((#t #f . ,index) ; unboxed
 426                             (emit-code #f (make-glil-lexical #t #f 'set index)))
 427                            ((#t #t . ,index) ; boxed
 428                             ;; new box
 429                             (emit-code #f (make-glil-lexical #t #t 'box index)))
 430                            (,x (error "what" x))))
 431                        (reverse (lambda-case-vars lcase)))
 432              (emit-branch src 'br (car (hashq-ref allocation lcase))))
 433             ((lambda-case? lcase)
 434              ;; no match, try next case
 435              (lp (lambda-case-alternate lcase)))
 436             (else
 437              ;; no cases left; shuffle args down and jump before the prelude.
 438              (for-each (lambda (i)
 439                          (emit-code #f (make-glil-lexical #t #f 'set i)))
 440                        (reverse (iota (length args))))
 441              (emit-branch src 'br self-label)))))
 442
 443         ;; lambda, the ultimate goto
 444         ((and (lexical-ref? proc)
 445               (assq (lexical-ref-gensym proc) fix-labels))
 446          ;; like the self-tail-call case, though we can handle "drop"
 447          ;; contexts too. first, evaluate new values, pushing them on
 448          ;; the stack
 449          (for-each comp-push args)
 450          ;; find the specific case, rename args, and goto the case label
 451          (let lp ((lcase (lambda-body
 452                           (assq-ref fix-labels (lexical-ref-gensym proc)))))
 453            (cond
 454             ((and (lambda-case? lcase)
 455                   (not (lambda-case-kw lcase))
 456                   (not (lambda-case-opt lcase))
 457                   (not (lambda-case-rest lcase))
 458                   (= (length args) (length (lambda-case-req lcase))))
 459              ;; we have a case that matches the args; rename variables
 460              ;; and goto the case label
 461              (for-each (lambda (sym)
 462                          (pmatch (hashq-ref (hashq-ref allocation sym) self)
 463                            ((#t #f . ,index) ; unboxed
 464                             (emit-code #f (make-glil-lexical #t #f 'set index)))
 465                            ((#t #t . ,index) ; boxed
 466                             (emit-code #f (make-glil-lexical #t #t 'box index)))
 467                            (,x (error "what" x))))
 468                        (reverse (lambda-case-vars lcase)))
 469              (emit-branch src 'br (car (hashq-ref allocation lcase))))
 470             ((lambda-case? lcase)
 471              ;; no match, try next case
 472              (lp (lambda-case-alternate lcase)))
 473             (else
 474              ;; no cases left. we can't really handle this currently.
 475              ;; ideally we would push on a new frame, then do a "local
 476              ;; call" -- which doesn't require consing up a program
 477              ;; object. but for now error, as this sort of case should
 478              ;; preclude label allocation.
 479              (error "couldn't find matching case for label call" x)))))
 480
 481         (else
 482          (if (not (eq? context 'tail))
 483              (emit-code src (make-glil-call 'new-frame 0)))
 484          (comp-push proc)
 485          (for-each comp-push args)
 486          (let ((len (length args)))
 487            (case context
 488              ((tail) (emit-code src (make-glil-call 'tail-call len)))
 489              ((push) (emit-code src (make-glil-call 'call len))
 490                      (maybe-emit-return))
 491              ((vals) (emit-code src (make-glil-mv-call len MVRA))
 492                      (maybe-emit-return))
 493              ((drop) (let ((MV (make-label)) (POST (make-label)))
 494                        (emit-code src (make-glil-mv-call len MV))
 495                        (emit-code #f (make-glil-call 'drop 1))
 496                        (emit-branch #f 'br (or RA POST))
 497                        (emit-label MV)
 498                        (emit-code #f (make-glil-mv-bind '() #f))
 499                        (emit-code #f (make-glil-unbind))
 500                        (if RA
 501                            (emit-branch #f 'br RA)
 502                            (emit-label POST)))))))))
 503
 504       ((<conditional> src test consequent alternate)
 505        ;;     TEST
 506        ;;     (br-if-not L1)
 507        ;;     consequent
 508        ;;     (br L2)
 509        ;; L1: alternate
 510        ;; L2:
 511        (let ((L1 (make-label)) (L2 (make-label)))
 512          ;; need a pattern matcher
 513          (record-case test
 514            ((<application> proc args)
 515             (record-case proc
 516               ((<primitive-ref> name)
 517                (let ((len (length args)))
 518                  (cond
 519
 520                   ((and (eq? name 'eq?) (= len 2))
 521                    (comp-push (car args))
 522                    (comp-push (cadr args))
 523                    (emit-branch src 'br-if-not-eq L1))
 524
 525                   ((and (eq? name 'null?) (= len 1))
 526                    (comp-push (car args))
 527                    (emit-branch src 'br-if-not-null L1))
 528
 529                   ((and (eq? name 'not) (= len 1))
 530                    (let ((app (car args)))
 531                      (record-case app
 532                        ((<application> proc args)
 533                         (let ((len (length args)))
 534                           (record-case proc
 535                             ((<primitive-ref> name)
 536                              (cond
 537
 538                               ((and (eq? name 'eq?) (= len 2))
 539                                (comp-push (car args))
 540                                (comp-push (cadr args))
 541                                (emit-branch src 'br-if-eq L1))
 542
 543                               ((and (eq? name 'null?) (= len 1))
 544                                (comp-push (car args))
 545                                (emit-branch src 'br-if-null L1))
 546
 547                               (else
 548                                (comp-push app)
 549                                (emit-branch src 'br-if L1))))
 550                             (else
 551                              (comp-push app)
 552                              (emit-branch src 'br-if L1)))))
 553                        (else
 554                         (comp-push app)
 555                         (emit-branch src 'br-if L1)))))
 556
 557                   (else
 558                    (comp-push test)
 559                    (emit-branch src 'br-if-not L1)))))
 560               (else
 561                (comp-push test)
 562                (emit-branch src 'br-if-not L1))))
 563            (else
 564             (comp-push test)
 565             (emit-branch src 'br-if-not L1)))
 566
 567          (comp-tail consequent)
 568          ;; if there is an RA, comp-tail will cause a jump to it -- just
 569          ;; have to clean up here if there is no RA.
 570          (if (and (not RA) (not (eq? context 'tail)))
 571              (emit-branch #f 'br L2))
 572          (emit-label L1)
 573          (comp-tail alternate)
 574          (if (and (not RA) (not (eq? context 'tail)))
 575              (emit-label L2))))
 576
 577       ((<primitive-ref> src name)
 578        (cond
 579         ((eq? (module-variable (fluid-ref *comp-module*) name)
 580               (module-variable the-root-module name))
 581          (case context
 582            ((tail push vals)
 583             (emit-code src (make-glil-toplevel 'ref name))))
 584          (maybe-emit-return))
 585         ((module-variable the-root-module name)
 586          (case context
 587            ((tail push vals)
 588             (emit-code src (make-glil-module 'ref '(guile) name #f))))
 589          (maybe-emit-return))
 590         (else
 591          (case context
 592            ((tail push vals)
 593             (emit-code src (make-glil-module
 594                             'ref (module-name (fluid-ref *comp-module*)) name #f))))
 595          (maybe-emit-return))))
 596
 597       ((<lexical-ref> src gensym)
 598        (case context
 599          ((push vals tail)
 600           (pmatch (hashq-ref (hashq-ref allocation gensym) self)
 601             ((,local? ,boxed? . ,index)
 602              (emit-code src (make-glil-lexical local? boxed? 'ref index)))
 603             (,loc
 604              (error "badness" x loc)))))
 605        (maybe-emit-return))
 606
 607       ((<lexical-set> src gensym exp)
 608        (comp-push exp)
 609        (pmatch (hashq-ref (hashq-ref allocation gensym) self)
 610          ((,local? ,boxed? . ,index)
 611           (emit-code src (make-glil-lexical local? boxed? 'set index)))
 612          (,loc
 613           (error "badness" x loc)))
 614        (case context
 615          ((tail push vals)
 616           (emit-code #f (make-glil-void))))
 617        (maybe-emit-return))
 618
 619       ((<module-ref> src mod name public?)
 620        (emit-code src (make-glil-module 'ref mod name public?))
 621        (case context
 622          ((drop) (emit-code #f (make-glil-call 'drop 1))))
 623        (maybe-emit-return))
 624
 625       ((<module-set> src mod name public? exp)
 626        (comp-push exp)
 627        (emit-code src (make-glil-module 'set mod name public?))
 628        (case context
 629          ((tail push vals)
 630           (emit-code #f (make-glil-void))))
 631        (maybe-emit-return))
 632
 633       ((<toplevel-ref> src name)
 634        (emit-code src (make-glil-toplevel 'ref name))
 635        (case context
 636          ((drop) (emit-code #f (make-glil-call 'drop 1))))
 637        (maybe-emit-return))
 638
 639       ((<toplevel-set> src name exp)
 640        (comp-push exp)
 641        (emit-code src (make-glil-toplevel 'set name))
 642        (case context
 643          ((tail push vals)
 644           (emit-code #f (make-glil-void))))
 645        (maybe-emit-return))
 646
 647       ((<toplevel-define> src name exp)
 648        (comp-push exp)
 649        (emit-code src (make-glil-toplevel 'define name))
 650        (case context
 651          ((tail push vals)
 652           (emit-code #f (make-glil-void))))
 653        (maybe-emit-return))
 654
 655       ((<lambda>)
 656        (let ((free-locs (cdr (hashq-ref allocation x))))
 657          (case context
 658            ((push vals tail)
 659             (emit-code #f (flatten-lambda x #f allocation))
 660             (if (not (null? free-locs))
 661                 (begin
 662                   (for-each
 663                    (lambda (loc)
 664                      (pmatch loc
 665                        ((,local? ,boxed? . ,n)
 666                         (emit-code #f (make-glil-lexical local? #f 'ref n)))
 667                        (else (error "what" x loc))))
 668                    free-locs)
 669                   (emit-code #f (make-glil-call 'make-closure
 670                                                 (length free-locs))))))))
 671        (maybe-emit-return))
 672
 673       ((<lambda-case> src req opt rest kw inits vars alternate body)
 674        ;; o/~ feature on top of feature o/~
 675        ;; req := (name ...)
 676        ;; opt := (name ...) | #f
 677        ;; rest := name | #f
 678        ;; kw: (allow-other-keys? (keyword name var) ...) | #f
 679        ;; vars: (sym ...)
 680        ;; init: tree-il in context of vars
 681        ;; vars map to named arguments in the following order:
 682        ;;  required, optional (positional), rest, keyword.
 683        (let* ((nreq (length req))
 684               (nopt (if opt (length opt) 0))
 685               (rest-idx (and rest (+ nreq nopt)))
 686               (opt-names (or opt '()))
 687               (allow-other-keys? (if kw (car kw) #f))
 688               (kw-indices (map (lambda (x)
 689                                  (pmatch x
 690                                    ((,key ,name ,var)
 691                                     (cons key (list-index vars var)))
 692                                    (else (error "bad kwarg" x))))
 693                                (if kw (cdr kw) '())))
 694               (nargs (apply max (+ nreq nopt (if rest 1 0))
 695                             (map 1+ (map cdr kw-indices))))
 696               (nlocs (cdr (hashq-ref allocation x)))
 697               (alternate-label (and alternate (make-label))))
 698          (or (= nargs
 699                 (length vars)
 700                 (+ nreq (length inits) (if rest 1 0)))
 701              (error "something went wrong"
 702                     req opt rest kw inits vars nreq nopt kw-indices nargs))
 703          ;; the prelude, to check args & reset the stack pointer,
 704          ;; allowing room for locals
 705          (emit-code
 706           src
 707           (cond
 708            (kw
 709             (make-glil-kw-prelude nreq nopt rest-idx kw-indices
 710                                   allow-other-keys? nlocs alternate-label))
 711            ((or rest opt)
 712             (make-glil-opt-prelude nreq nopt rest-idx nlocs alternate-label))
 713            (#t
 714             (make-glil-std-prelude nreq nlocs alternate-label))))
 715          ;; box args if necessary
 716          (for-each
 717           (lambda (v)
 718             (pmatch (hashq-ref (hashq-ref allocation v) self)
 719               ((#t #t . ,n)
 720                (emit-code #f (make-glil-lexical #t #f 'ref n))
 721                (emit-code #f (make-glil-lexical #t #t 'box n)))))
 722           vars)
 723          ;; write bindings info
 724          (if (not (null? vars))
 725              (emit-bindings
 726               #f
 727               (let lp ((kw (if kw (cdr kw) '()))
 728                        (names (append (reverse opt-names) (reverse req)))
 729                        (vars (list-tail vars (+ nreq nopt
 730                                                 (if rest 1 0)))))
 731                 (pmatch kw
 732                   (()
 733                    ;; fixme: check that vars is empty
 734                    (reverse (if rest (cons rest names) names)))
 735                   (((,key ,name ,var) . ,kw)
 736                    (if (memq var vars)
 737                        (lp kw (cons name names) (delq var vars))
 738                        (lp kw names vars)))
 739                   (,kw (error "bad keywords, yo" kw))))
 740               vars allocation self emit-code))
 741          ;; init optional/kw args
 742          (let lp ((inits inits) (n nreq) (vars (list-tail vars nreq)))
 743            (cond
 744             ((null? inits))             ; done
 745             ((and rest-idx (= n rest-idx))
 746              (lp inits (1+ n) (cdr vars)))
 747             (#t
 748              (pmatch (hashq-ref (hashq-ref allocation (car vars)) self)
 749                ((#t ,boxed? . ,n*) (guard (= n* n))
 750                 (let ((L (make-label)))
 751                   (emit-code #f (make-glil-lexical #t boxed? 'bound? n))
 752                   (emit-code #f (make-glil-branch 'br-if L))
 753                   (comp-push (car inits))
 754                   (emit-code #f (make-glil-lexical #t boxed? 'set n))
 755                   (emit-label L)
 756                   (lp (cdr inits) (1+ n) (cdr vars))))
 757                (#t (error "what" inits))))))
 758          ;; post-prelude case label for label calls
 759          (emit-label (car (hashq-ref allocation x)))
 760          (comp-tail body)
 761          (if (not (null? vars))
 762              (emit-code #f (make-glil-unbind)))
 763          (if alternate-label
 764              (begin
 765                (emit-label alternate-label)
 766                (comp-tail alternate)))))
 767
 768       ((<let> src names vars vals body)
 769        (for-each comp-push vals)
 770        (emit-bindings src names vars allocation self emit-code)
 771        (for-each (lambda (v)
 772                    (pmatch (hashq-ref (hashq-ref allocation v) self)
 773                      ((#t #f . ,n)
 774                       (emit-code src (make-glil-lexical #t #f 'set n)))
 775                      ((#t #t . ,n)
 776                       (emit-code src (make-glil-lexical #t #t 'box n)))
 777                      (,loc (error "badness" x loc))))
 778                  (reverse vars))
 779        (comp-tail body)
 780        (emit-code #f (make-glil-unbind)))
 781
 782       ((<letrec> src names vars vals body)
 783        (for-each (lambda (v)
 784                    (pmatch (hashq-ref (hashq-ref allocation v) self)
 785                      ((#t #t . ,n)
 786                       (emit-code src (make-glil-lexical #t #t 'empty-box n)))
 787                      (,loc (error "badness" x loc))))
 788                  vars)
 789        (for-each comp-push vals)
 790        (emit-bindings src names vars allocation self emit-code)
 791        (for-each (lambda (v)
 792                    (pmatch (hashq-ref (hashq-ref allocation v) self)
 793                      ((#t #t . ,n)
 794                       (emit-code src (make-glil-lexical #t #t 'set n)))
 795                      (,loc (error "badness" x loc))))
 796                  (reverse vars))
 797        (comp-tail body)
 798        (emit-code #f (make-glil-unbind)))
 799
 800       ((<fix> src names vars vals body)
 801        ;; The ideal here is to just render the lambda bodies inline, and
 802        ;; wire the code together with gotos. We can do that if
 803        ;; analyze-lexicals has determined that a given var has "label"
 804        ;; allocation -- which is the case if it is in `fix-labels'.
 805        ;;
 806        ;; But even for closures that we can't inline, we can do some
 807        ;; tricks to avoid heap-allocation for the binding itself. Since
 808        ;; we know the vals are lambdas, we can set them to their local
 809        ;; var slots first, then capture their bindings, mutating them in
 810        ;; place.
 811        (let ((new-RA (if (or (eq? context 'tail) RA) #f (make-label))))
 812          (for-each
 813           (lambda (x v)
 814             (cond
 815              ((hashq-ref allocation x)
 816               ;; allocating a closure
 817               (emit-code #f (flatten-lambda x v allocation))
 818               (let ((free-locs (cdr (hashq-ref allocation x))))
 819                 (if (not (null? free-locs))
 820                     ;; Need to make-closure first, so we have a fresh closure on
 821                     ;; the heap, but with a temporary free values.
 822                     (begin
 823                       (for-each (lambda (loc)
 824                                   (emit-code #f (make-glil-const #f)))
 825                                 free-locs)
 826                       (emit-code #f (make-glil-call 'make-closure
 827                                                     (length free-locs))))))
 828               (pmatch (hashq-ref (hashq-ref allocation v) self)
 829                 ((#t #f . ,n)
 830                  (emit-code src (make-glil-lexical #t #f 'set n)))
 831                 (,loc (error "badness" x loc))))
 832              (else
 833               ;; labels allocation: emit label & body, but jump over it
 834               (let ((POST (make-label)))
 835                 (emit-branch #f 'br POST)
 836                 (let lp ((lcase (lambda-body x)))
 837                   (if lcase
 838                       (record-case lcase
 839                         ((<lambda-case> src req vars body alternate)
 840                          (emit-label (car (hashq-ref allocation lcase)))
 841                          ;; FIXME: opt & kw args in the bindings
 842                          (emit-bindings #f req vars allocation self emit-code)
 843                          (if src
 844                              (emit-code #f (make-glil-source src)))
 845                          (comp-fix body (or RA new-RA))
 846                          (emit-code #f (make-glil-unbind))
 847                          (lp alternate)))
 848                       (emit-label POST)))))))
 849           vals
 850           vars)
 851          ;; Emit bindings metadata for closures
 852          (let ((binds (let lp ((out '()) (vars vars) (names names))
 853                         (cond ((null? vars) (reverse! out))
 854                               ((assq (car vars) fix-labels)
 855                                (lp out (cdr vars) (cdr names)))
 856                               (else
 857                                (lp (acons (car vars) (car names) out)
 858                                    (cdr vars) (cdr names)))))))
 859            (emit-bindings src (map cdr binds) (map car binds)
 860                           allocation self emit-code))
 861          ;; Now go back and fix up the bindings for closures.
 862          (for-each
 863           (lambda (x v)
 864             (let ((free-locs (if (hashq-ref allocation x)
 865                                  (cdr (hashq-ref allocation x))
 866                                  ;; can hit this latter case for labels allocation
 867                                  '())))
 868               (if (not (null? free-locs))
 869                   (begin
 870                     (for-each
 871                      (lambda (loc)
 872                        (pmatch loc
 873                          ((,local? ,boxed? . ,n)
 874                           (emit-code #f (make-glil-lexical local? #f 'ref n)))
 875                          (else (error "what" x loc))))
 876                      free-locs)
 877                     (pmatch (hashq-ref (hashq-ref allocation v) self)
 878                       ((#t #f . ,n)
 879                        (emit-code #f (make-glil-lexical #t #f 'fix n)))
 880                       (,loc (error "badness" x loc)))))))
 881           vals
 882           vars)
 883          (comp-tail body)
 884          (if new-RA
 885              (emit-label new-RA))
 886          (emit-code #f (make-glil-unbind))))
 887
 888       ((<let-values> src exp body)
 889        (record-case body
 890          ((<lambda-case> req opt kw rest vars body alternate)
 891           (if (or opt kw alternate)
 892               (error "unexpected lambda-case in let-values" x))
 893           (let ((MV (make-label)))
 894             (comp-vals exp MV)
 895             (emit-code #f (make-glil-const 1))
 896             (emit-label MV)
 897             (emit-code src (make-glil-mv-bind
 898                             (vars->bind-list
 899                              (append req (if rest (list rest) '()))
 900                              vars allocation self)
 901                             (and rest #t)))
 902             (for-each (lambda (v)
 903                         (pmatch (hashq-ref (hashq-ref allocation v) self)
 904                           ((#t #f . ,n)
 905                            (emit-code src (make-glil-lexical #t #f 'set n)))
 906                           ((#t #t . ,n)
 907                            (emit-code src (make-glil-lexical #t #t 'box n)))
 908                           (,loc (error "badness" x loc))))
 909                       (reverse vars))
 910             (comp-tail body)
 911             (emit-code #f (make-glil-unbind)))))))))