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