;;; TREE-IL -> GLIL compiler
-;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001,2008,2009,2010,2011,2012,2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
#:use-module (system vm instruction)
#:use-module (language tree-il)
#:use-module (language tree-il optimize)
+ #:use-module (language tree-il canonicalize)
#:use-module (language tree-il analyze)
+ #:use-module ((srfi srfi-1) #:select (filter-map))
#:export (compile-glil))
-;;; TODO:
-;;
-;; call-with-values -> mv-bind
-;; basic degenerate-case reduction
-
;; allocation:
;; sym -> {lambda -> address}
-;; lambda -> (nlocs labels . free-locs)
+;; lambda -> (labels . free-locs)
+;; lambda-case -> (gensym . nlocs)
;;
-;; address := (local? boxed? . index)
+;; address ::= (local? boxed? . index)
+;; labels ::= ((sym . lambda) ...)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
;; free variable addresses are relative to parent proc.
(define *comp-module* (make-fluid))
(define %warning-passes
- `((unused-variable . ,report-unused-variables)))
+ `((unused-variable . ,unused-variable-analysis)
+ (unused-toplevel . ,unused-toplevel-analysis)
+ (unbound-variable . ,unbound-variable-analysis)
+ (arity-mismatch . ,arity-analysis)
+ (format . ,format-analysis)))
(define (compile-glil x e opts)
(define warnings
(or (and=> (memq #:warnings opts) cadr)
'()))
- ;; Go throught the warning passes.
- (for-each (lambda (kind)
- (let ((warn (assoc-ref %warning-passes kind)))
- (and (procedure? warn)
- (warn x))))
- warnings)
+ ;; Go through the warning passes.
+ (let ((analyses (filter-map (lambda (kind)
+ (assoc-ref %warning-passes kind))
+ warnings)))
+ (analyze-tree analyses x e))
- (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
+ (let* ((x (make-lambda (tree-il-src x) '()
+ (make-lambda-case #f '() #f #f #f '() '() x #f)))
(x (optimize! x e opts))
+ (x (canonicalize! x))
(allocation (analyze-lexicals x)))
- (with-fluid* *comp-module* (or (and e (car e)) (current-module))
- (lambda ()
- (values (flatten-lambda x #f allocation)
- (and e (cons (car e) (cddr e)))
- e)))))
+ (with-fluids ((*comp-module* e))
+ (values (flatten-lambda x #f allocation)
+ e
+ e))))
\f
((quotient . 2) . quo)
((remainder . 2) . rem)
((modulo . 2) . mod)
+ ((ash . 2) . ash)
+ ((logand . 2) . logand)
+ ((logior . 2) . logior)
+ ((logxor . 2) . logxor)
((not . 1) . not)
((pair? . 1) . pair?)
((cons . 2) . cons)
((set-cdr! . 2) . set-cdr!)
((null? . 1) . null?)
((list? . 1) . list?)
+ ((symbol? . 1) . symbol?)
+ ((vector? . 1) . vector?)
+ ((nil? . 1) . nil?)
(list . list)
(vector . vector)
+ ((class-of . 1) . class-of)
((@slot-ref . 2) . slot-ref)
((@slot-set! . 3) . slot-set)
+ ((string-length . 1) . string-length)
+ ((string-ref . 2) . string-ref)
+ ((vector-length . 1) . vector-length)
((vector-ref . 2) . vector-ref)
((vector-set! . 3) . vector-set)
+ ((variable-ref . 1) . variable-ref)
+ ;; nb, *not* variable-set! -- the args are switched
+ ((variable-bound? . 1) . variable-bound?)
+ ((struct? . 1) . struct?)
+ ((struct-vtable . 1) . struct-vtable)
+ ((struct-ref . 2) . struct-ref)
+ ((struct-set! . 3) . struct-set)
+ (make-struct/no-tail . make-struct)
+
+ ;; hack for javascript
+ ((return . 1) . return)
+ ;; hack for lua
+ (return/values . return/values)
((bytevector-u8-ref . 2) . bv-u8-ref)
((bytevector-u8-set! . 3) . bv-u8-set)
(pmatch (hashq-ref (hashq-ref allocation v) proc)
((#t ,boxed? . ,n)
(list id boxed? n))
- (,x (error "badness" x))))
+ (,x (error "bad var list element" id v x))))
ids
vars))
-;; FIXME: always emit? otherwise it's hard to pair bind with unbind
(define (emit-bindings src ids vars allocation proc emit-code)
(emit-code src (make-glil-bind
(vars->bind-list ids vars allocation proc))))
(reverse out)))
(define (flatten-lambda x self-label allocation)
- (receive (ids vars nargs nrest)
- (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
- (oids '()) (ovars '()) (n 0))
- (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0))
- ((pair? vars) (lp (cdr ids) (cdr vars)
- (cons (car ids) oids) (cons (car vars) ovars)
- (1+ n)))
- (else (values (reverse (cons ids oids))
- (reverse (cons vars ovars))
- (1+ n) 1))))
- (let ((nlocs (car (hashq-ref allocation x)))
- (labels (cadr (hashq-ref allocation x))))
- (make-glil-program
- nargs nrest nlocs (lambda-meta x)
- (with-output-to-code
- (lambda (emit-code)
- ;; emit label for self tail calls
- (if self-label
- (emit-code #f (make-glil-label self-label)))
- ;; write bindings and source debugging info
- (if (not (null? ids))
- (emit-bindings #f ids vars allocation x emit-code))
- (if (lambda-src x)
- (emit-code #f (make-glil-source (lambda-src x))))
- ;; box args if necessary
- (for-each
- (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) x)
- ((#t #t . ,n)
- (emit-code #f (make-glil-lexical #t #f 'ref n))
- (emit-code #f (make-glil-lexical #t #t 'box n)))))
- vars)
- ;; and here, here, dear reader: we compile.
- (flatten (lambda-body x) allocation x self-label
- labels emit-code)))))))
-
-(define (flatten x allocation self self-label fix-labels emit-code)
+ (record-case x
+ ((<lambda> src meta body)
+ (make-glil-program
+ meta
+ (with-output-to-code
+ (lambda (emit-code)
+ ;; write source info for proc
+ (if src (emit-code #f (make-glil-source src)))
+ ;; compile the body, yo
+ (flatten-lambda-case body allocation x self-label
+ (car (hashq-ref allocation x))
+ emit-code)))))))
+
+(define (flatten-lambda-case lcase allocation self self-label fix-labels
+ emit-code)
(define (emit-label label)
(emit-code #f (make-glil-label label)))
(define (emit-branch src inst label)
;; RA: "return address"; #f unless we're in a non-tail fix with labels
;; MVRA: "multiple-values return address"; #f unless we're in a let-values
- (let comp ((x x) (context 'tail) (RA #f) (MVRA #f))
+ (let comp ((x lcase) (context 'tail) (RA #f) (MVRA #f))
(define (comp-tail tree) (comp tree context RA MVRA))
(define (comp-push tree) (comp tree 'push #f #f))
(define (comp-drop tree) (comp tree 'drop #f #f))
(if (eq? context 'tail)
(emit-code #f (make-glil-call 'return 1)))))
+ ;; After lexical binding forms in non-tail context, call this
+ ;; function to clear stack slots, allowing their previous values to
+ ;; be collected.
+ (define (clear-stack-slots context syms)
+ (case context
+ ((push drop)
+ (for-each (lambda (v)
+ (and=>
+ ;; Can be #f if the var is labels-allocated.
+ (hashq-ref allocation v)
+ (lambda (h)
+ (pmatch (hashq-ref h self)
+ ((#t _ . ,n)
+ (emit-code #f (make-glil-void))
+ (emit-code #f (make-glil-lexical #t #f 'set n)))
+ (,loc (error "bad let var allocation" x loc))))))
+ syms))))
+
(record-case x
((<void>)
(case context
(emit-code src (make-glil-const exp))))
(maybe-emit-return))
- ;; FIXME: should represent sequence as exps tail
- ((<sequence> src exps)
- (let lp ((exps exps))
- (if (null? (cdr exps))
- (comp-tail (car exps))
- (begin
- (comp-drop (car exps))
- (lp (cdr exps))))))
-
- ((<application> src proc args)
- ;; FIXME: need a better pattern-matcher here
+ ((<seq> head tail)
+ (comp-drop head)
+ (comp-tail tail))
+
+ ((<call> src proc args)
(cond
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@apply)
- (>= (length args) 1))
- (let ((proc (car args))
- (args (cdr args)))
- (cond
- ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
- (not (eq? context 'push)) (not (eq? context 'vals)))
- ;; tail: (lambda () (apply values '(1 2)))
- ;; drop: (lambda () (apply values '(1 2)) 3)
- ;; push: (lambda () (list (apply values '(10 12)) 1))
- (case context
- ((drop) (for-each comp-drop args) (maybe-emit-return))
- ((tail)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'return/values* (length args))))))
-
- (else
- (case context
- ((tail)
- (comp-push proc)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'goto/apply (1+ (length args)))))
- ((push)
- (comp-push proc)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'apply (1+ (length args))))
- (maybe-emit-return))
- ((vals)
- (comp-vals
- (make-application src (make-primitive-ref #f 'apply)
- (cons proc args))
- MVRA)
- (maybe-emit-return))
- ((drop)
- ;; Well, shit. The proc might return any number of
- ;; values (including 0), since it's in a drop context,
- ;; yet apply does not create a MV continuation. So we
- ;; mv-call out to our trampoline instead.
- (comp-drop
- (make-application src (make-primitive-ref #f 'apply)
- (cons proc args)))
- (maybe-emit-return)))))))
-
- ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
- (not (eq? context 'push)))
- ;; tail: (lambda () (values '(1 2)))
- ;; drop: (lambda () (values '(1 2)) 3)
- ;; push: (lambda () (list (values '(10 12)) 1))
- ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
- (case context
- ((drop) (for-each comp-drop args) (maybe-emit-return))
- ((vals)
- (for-each comp-push args)
- (emit-code #f (make-glil-const (length args)))
- (emit-branch src 'br MVRA))
- ((tail)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'return/values (length args))))))
-
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-values)
- (= (length args) 2))
- ;; CONSUMER
- ;; PRODUCER
- ;; (mv-call MV)
- ;; ([tail]-call 1)
- ;; goto POST
- ;; MV: [tail-]call/nargs
- ;; POST: (maybe-drop)
- (case context
- ((vals)
- ;; Fall back.
- (comp-vals
- (make-application src (make-primitive-ref #f 'call-with-values)
- args)
- MVRA)
- (maybe-emit-return))
- (else
- (let ((MV (make-label)) (POST (make-label))
- (producer (car args)) (consumer (cadr args)))
- (comp-push consumer)
- (comp-push producer)
- (emit-code src (make-glil-mv-call 0 MV))
- (case context
- ((tail) (emit-code src (make-glil-call 'goto/args 1)))
- (else (emit-code src (make-glil-call 'call 1))
- (emit-branch #f 'br POST)))
- (emit-label MV)
- (case context
- ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
- (else (emit-code src (make-glil-call 'call/nargs 0))
- (emit-label POST)
- (if (eq? context 'drop)
- (emit-code #f (make-glil-call 'drop 1)))
- (maybe-emit-return)))))))
-
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-current-continuation)
- (= (length args) 1))
- (case context
- ((tail)
- (comp-push (car args))
- (emit-code src (make-glil-call 'goto/cc 1)))
- ((vals)
- (comp-vals
- (make-application
- src (make-primitive-ref #f 'call-with-current-continuation)
- args)
- MVRA)
- (maybe-emit-return))
- ((push)
- (comp-push (car args))
- (emit-code src (make-glil-call 'call/cc 1))
- (maybe-emit-return))
- ((drop)
- ;; Crap. Just like `apply' in drop context.
- (comp-drop
- (make-application
- src (make-primitive-ref #f 'call-with-current-continuation)
- args))
- (maybe-emit-return))))
-
- ((and (primitive-ref? proc)
- (or (hash-ref *primcall-ops*
- (cons (primitive-ref-name proc) (length args)))
- (hash-ref *primcall-ops* (primitive-ref-name proc))))
- => (lambda (op)
- (for-each comp-push args)
- (emit-code src (make-glil-call op (length args)))
- (case (instruction-pushes op)
- ((0)
- (case context
- ((tail push vals) (emit-code #f (make-glil-void))))
- (maybe-emit-return))
- ((1)
- (case context
- ((drop) (emit-code #f (make-glil-call 'drop 1))))
- (maybe-emit-return))
- (else
- (error "bad primitive op: too many pushes"
- op (instruction-pushes op))))))
-
- ;; da capo al fine
+ ;; call to the same lambda-case in tail position
((and (lexical-ref? proc)
self-label (eq? (lexical-ref-gensym proc) self-label)
- ;; self-call in tail position is a goto
(eq? context 'tail)
- ;; make sure the arity is right
- (list? (lambda-vars self))
- (= (length args) (length (lambda-vars self))))
- ;; evaluate new values
+ (not (lambda-case-kw lcase))
+ (not (lambda-case-rest lcase))
+ (= (length args)
+ (+ (length (lambda-case-req lcase))
+ (or (and=> (lambda-case-opt lcase) length) 0))))
(for-each comp-push args)
- ;; rename & goto
(for-each (lambda (sym)
(pmatch (hashq-ref (hashq-ref allocation sym) self)
- ((#t ,boxed? . ,index)
- ;; set unboxed, as the proc prelude will box if needed
+ ((#t #f . ,index) ; unboxed
(emit-code #f (make-glil-lexical #t #f 'set index)))
- (,x (error "what" x))))
- (reverse (lambda-vars self)))
- (emit-branch src 'br self-label))
+ ((#t #t . ,index) ; boxed
+ ;; new box
+ (emit-code #f (make-glil-lexical #t #t 'box index)))
+ (,x (error "bad lambda-case arg allocation" x))))
+ (reverse (lambda-case-gensyms lcase)))
+ (emit-branch src 'br (car (hashq-ref allocation lcase))))
;; lambda, the ultimate goto
((and (lexical-ref? proc)
(assq (lexical-ref-gensym proc) fix-labels))
- ;; evaluate new values, assuming that analyze-lexicals did its
- ;; job, and that the arity was right
+ ;; like the self-tail-call case, though we can handle "drop"
+ ;; contexts too. first, evaluate new values, pushing them on
+ ;; the stack
(for-each comp-push args)
- ;; rename
- (for-each (lambda (sym)
- (pmatch (hashq-ref (hashq-ref allocation sym) self)
- ((#t #f . ,index)
- (emit-code #f (make-glil-lexical #t #f 'set index)))
- ((#t #t . ,index)
- (emit-code #f (make-glil-lexical #t #t 'box index)))
- (,x (error "what" x))))
- (reverse (assq-ref fix-labels (lexical-ref-gensym proc))))
- ;; goto!
- (emit-branch src 'br (lexical-ref-gensym proc)))
+ ;; find the specific case, rename args, and goto the case label
+ (let lp ((lcase (lambda-body
+ (assq-ref fix-labels (lexical-ref-gensym proc)))))
+ (cond
+ ((and (lambda-case? lcase)
+ (not (lambda-case-kw lcase))
+ (not (lambda-case-opt lcase))
+ (not (lambda-case-rest lcase))
+ (= (length args) (length (lambda-case-req lcase))))
+ ;; we have a case that matches the args; rename variables
+ ;; and goto the case label
+ (for-each (lambda (sym)
+ (pmatch (hashq-ref (hashq-ref allocation sym) self)
+ ((#t #f . ,index) ; unboxed
+ (emit-code #f (make-glil-lexical #t #f 'set index)))
+ ((#t #t . ,index) ; boxed
+ (emit-code #f (make-glil-lexical #t #t 'box index)))
+ (,x (error "bad lambda-case arg allocation" x))))
+ (reverse (lambda-case-gensyms lcase)))
+ (emit-branch src 'br (car (hashq-ref allocation lcase))))
+ ((lambda-case? lcase)
+ ;; no match, try next case
+ (lp (lambda-case-alternate lcase)))
+ (else
+ ;; no cases left. we can't really handle this currently.
+ ;; ideally we would push on a new frame, then do a "local
+ ;; call" -- which doesn't require consing up a program
+ ;; object. but for now error, as this sort of case should
+ ;; preclude label allocation.
+ (error "couldn't find matching case for label call" x)))))
(else
+ (if (not (eq? context 'tail))
+ (emit-code src (make-glil-call 'new-frame 0)))
(comp-push proc)
(for-each comp-push args)
(let ((len (length args)))
(case context
- ((tail) (emit-code src (make-glil-call 'goto/args len)))
- ((push) (emit-code src (make-glil-call 'call len))
+ ((tail) (if (<= len #xff)
+ (emit-code src (make-glil-call 'tail-call len))
+ (begin
+ (comp-push (make-const #f len))
+ (emit-code src (make-glil-call 'tail-call/nargs 0)))))
+ ((push) (if (<= len #xff)
+ (emit-code src (make-glil-call 'call len))
+ (begin
+ (comp-push (make-const #f len))
+ (emit-code src (make-glil-call 'call/nargs 0))))
(maybe-emit-return))
+ ;; FIXME: mv-call doesn't have a /nargs variant, so it is
+ ;; limited to 255 args. Can work around it with a
+ ;; trampoline and tail-call/nargs, but it's not so nice.
((vals) (emit-code src (make-glil-mv-call len MVRA))
(maybe-emit-return))
((drop) (let ((MV (make-label)) (POST (make-label)))
(emit-code #f (make-glil-call 'drop 1))
(emit-branch #f 'br (or RA POST))
(emit-label MV)
- (emit-code #f (make-glil-mv-bind '() #f))
- (emit-code #f (make-glil-unbind))
+ (emit-code #f (make-glil-mv-bind 0 #f))
(if RA
(emit-branch #f 'br RA)
(emit-label POST)))))))))
- ((<conditional> src test then else)
+ ((<primcall> src name args)
+ (pmatch (cons name args)
+ ((@apply ,proc . ,args)
+ (cond
+ ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
+ (not (eq? context 'push)) (not (eq? context 'vals)))
+ ;; tail: (lambda () (apply values '(1 2)))
+ ;; drop: (lambda () (apply values '(1 2)) 3)
+ ;; push: (lambda () (list (apply values '(10 12)) 1))
+ (case context
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'return/values* (length args))))))
+
+ (else
+ (case context
+ ((tail)
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
+ ((push)
+ (emit-code src (make-glil-call 'new-frame 0))
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'apply (1+ (length args))))
+ (maybe-emit-return))
+ (else
+ (comp-tail (make-primcall src 'apply (cons proc args))))))))
+
+ ((values . _)
+ ;; tail: (lambda () (values '(1 2)))
+ ;; drop: (lambda () (values '(1 2)) 3)
+ ;; push: (lambda () (list (values '(10 12)) 1))
+ ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
+ (case context
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
+ ((push)
+ (case (length args)
+ ((0)
+ ;; FIXME: This is surely an error. We need to add a
+ ;; values-mismatch warning pass.
+ (comp-push (make-call src (make-primitive-ref #f 'values)
+ '())))
+ (else
+ ;; Taking advantage of unspecified order of evaluation of
+ ;; arguments.
+ (for-each comp-drop (cdr args))
+ (comp-push (car args))
+ (maybe-emit-return))))
+ ((vals)
+ (for-each comp-push args)
+ (emit-code #f (make-glil-const (length args)))
+ (emit-branch src 'br MVRA))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (let ((len (length args)))
+ (if (= len 1)
+ (make-glil-call 'return 1)
+ (make-glil-call 'return/values len)))))))
+
+ ((@call-with-values ,producer ,consumer)
+ ;; CONSUMER
+ ;; PRODUCER
+ ;; (mv-call MV)
+ ;; ([tail]-call 1)
+ ;; goto POST
+ ;; MV: [tail-]call/nargs
+ ;; POST: (maybe-drop)
+ (case context
+ ((vals)
+ ;; Fall back.
+ (comp-tail (make-primcall src 'call-with-values args)))
+ (else
+ (let ((MV (make-label)) (POST (make-label)))
+ (if (not (eq? context 'tail))
+ (emit-code src (make-glil-call 'new-frame 0)))
+ (comp-push consumer)
+ (emit-code src (make-glil-call 'new-frame 0))
+ (comp-push producer)
+ (emit-code src (make-glil-mv-call 0 MV))
+ (case context
+ ((tail) (emit-code src (make-glil-call 'tail-call 1)))
+ (else (emit-code src (make-glil-call 'call 1))
+ (emit-branch #f 'br POST)))
+ (emit-label MV)
+ (case context
+ ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
+ (else (emit-code src (make-glil-call 'call/nargs 0))
+ (emit-label POST)
+ (if (eq? context 'drop)
+ (emit-code #f (make-glil-call 'drop 1)))
+ (maybe-emit-return)))))))
+
+ ((@call-with-current-continuation ,proc)
+ (case context
+ ((tail)
+ (comp-push proc)
+ (emit-code src (make-glil-call 'tail-call/cc 1)))
+ ((vals)
+ (comp-vals
+ (make-primcall src 'call-with-current-continuation args)
+ MVRA)
+ (maybe-emit-return))
+ ((push)
+ (comp-push proc)
+ (emit-code src (make-glil-call 'call/cc 1))
+ (maybe-emit-return))
+ ((drop)
+ ;; Fall back.
+ (comp-tail
+ (make-primcall src 'call-with-current-continuation args)))))
+
+ ;; A hack for variable-set, the opcode for which takes its args
+ ;; reversed, relative to the variable-set! function
+ ((variable-set! ,var ,val)
+ (comp-push val)
+ (comp-push var)
+ (emit-code src (make-glil-call 'variable-set 2))
+ (case context
+ ((tail push vals) (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ (else
+ (cond
+ ((or (hash-ref *primcall-ops* (cons name (length args)))
+ (hash-ref *primcall-ops* name))
+ => (lambda (op)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call op (length args)))
+ (case (instruction-pushes op)
+ ((0)
+ (case context
+ ((tail push vals) (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+ ((1)
+ (case context
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
+ ((-1)
+ ;; A control instruction, like return/values. Here we
+ ;; just have to hope that the author of the tree-il
+ ;; knew what they were doing.
+ *unspecified*)
+ (else
+ (error "bad primitive op: too many pushes"
+ op (instruction-pushes op))))))
+ (else
+ ;; Fall back to the normal compilation strategy.
+ (comp-tail (make-call src (make-primitive-ref #f name) args)))))))
+
+ ((<conditional> src test consequent alternate)
;; TEST
;; (br-if-not L1)
- ;; THEN
+ ;; consequent
;; (br L2)
- ;; L1: ELSE
+ ;; L1: alternate
;; L2:
(let ((L1 (make-label)) (L2 (make-label)))
- (comp-push test)
- (emit-branch src 'br-if-not L1)
- (comp-tail then)
+ (record-case test
+ ((<primcall> name args)
+ (pmatch (cons name args)
+ ((eq? ,a ,b)
+ (comp-push a)
+ (comp-push b)
+ (emit-branch src 'br-if-not-eq L1))
+ ((null? ,x)
+ (comp-push x)
+ (emit-branch src 'br-if-not-null L1))
+ ((nil? ,x)
+ (comp-push x)
+ (emit-branch src 'br-if-not-nil L1))
+ ((not ,x)
+ (record-case x
+ ((<primcall> name args)
+ (pmatch (cons name args)
+ ((eq? ,a ,b)
+ (comp-push a)
+ (comp-push b)
+ (emit-branch src 'br-if-eq L1))
+ ((null? ,x)
+ (comp-push x)
+ (emit-branch src 'br-if-null L1))
+ ((nil? ,x)
+ (comp-push x)
+ (emit-branch src 'br-if-nil L1))
+ (else
+ (comp-push x)
+ (emit-branch src 'br-if L1))))
+ (else
+ (comp-push x)
+ (emit-branch src 'br-if L1))))
+ (else
+ (comp-push test)
+ (emit-branch src 'br-if-not L1))))
+ (else
+ (comp-push test)
+ (emit-branch src 'br-if-not L1)))
+
+ (comp-tail consequent)
;; if there is an RA, comp-tail will cause a jump to it -- just
;; have to clean up here if there is no RA.
(if (and (not RA) (not (eq? context 'tail)))
(emit-branch #f 'br L2))
(emit-label L1)
- (comp-tail else)
+ (comp-tail alternate)
(if (and (not RA) (not (eq? context 'tail)))
(emit-label L2))))
'ref (module-name (fluid-ref *comp-module*)) name #f))))
(maybe-emit-return))))
- ((<lexical-ref> src name gensym)
+ ((<lexical-ref> src gensym)
(case context
((push vals tail)
(pmatch (hashq-ref (hashq-ref allocation gensym) self)
((,local? ,boxed? . ,index)
(emit-code src (make-glil-lexical local? boxed? 'ref index)))
(,loc
- (error "badness" x loc)))))
+ (error "bad lexical allocation" x loc)))))
(maybe-emit-return))
- ((<lexical-set> src name gensym exp)
+ ((<lexical-set> src gensym exp)
(comp-push exp)
(pmatch (hashq-ref (hashq-ref allocation gensym) self)
((,local? ,boxed? . ,index)
(emit-code src (make-glil-lexical local? boxed? 'set index)))
(,loc
- (error "badness" x loc)))
+ (error "bad lexical allocation" x loc)))
(case context
((tail push vals)
(emit-code #f (make-glil-void))))
(maybe-emit-return))
((<lambda>)
- (let ((free-locs (cddr (hashq-ref allocation x))))
+ (let ((free-locs (cdr (hashq-ref allocation x))))
(case context
((push vals tail)
(emit-code #f (flatten-lambda x #f allocation))
(pmatch loc
((,local? ,boxed? . ,n)
(emit-code #f (make-glil-lexical local? #f 'ref n)))
- (else (error "what" x loc))))
+ (else (error "bad lambda free var allocation" x loc))))
free-locs)
- (emit-code #f (make-glil-call 'vector (length free-locs)))
- (emit-code #f (make-glil-call 'make-closure 2)))))))
+ (emit-code #f (make-glil-call 'make-closure
+ (length free-locs))))))))
(maybe-emit-return))
- ((<let> src names vars vals body)
+ ((<lambda-case> src req opt rest kw inits gensyms alternate body)
+ ;; o/~ feature on top of feature o/~
+ ;; req := (name ...)
+ ;; opt := (name ...) | #f
+ ;; rest := name | #f
+ ;; kw: (allow-other-keys? (keyword name var) ...) | #f
+ ;; gensyms: (sym ...)
+ ;; init: tree-il in context of gensyms
+ ;; gensyms map to named arguments in the following order:
+ ;; required, optional (positional), rest, keyword.
+ (let* ((nreq (length req))
+ (nopt (if opt (length opt) 0))
+ (rest-idx (and rest (+ nreq nopt)))
+ (opt-names (or opt '()))
+ (allow-other-keys? (if kw (car kw) #f))
+ (kw-indices (map (lambda (x)
+ (pmatch x
+ ((,key ,name ,var)
+ (cons key (list-index gensyms var)))
+ (else (error "bad kwarg" x))))
+ (if kw (cdr kw) '())))
+ (nargs (apply max (+ nreq nopt (if rest 1 0))
+ (map 1+ (map cdr kw-indices))))
+ (nlocs (cdr (hashq-ref allocation x)))
+ (alternate-label (and alternate (make-label))))
+ (or (= nargs
+ (length gensyms)
+ (+ nreq (length inits) (if rest 1 0)))
+ (error "lambda-case gensyms don't correspond to args"
+ req opt rest kw inits gensyms nreq nopt kw-indices nargs))
+ ;; the prelude, to check args & reset the stack pointer,
+ ;; allowing room for locals
+ (emit-code
+ src
+ (cond
+ (kw
+ (make-glil-kw-prelude nreq nopt rest-idx kw-indices
+ allow-other-keys? nlocs alternate-label))
+ ((or rest opt)
+ (make-glil-opt-prelude nreq nopt rest-idx nlocs alternate-label))
+ (#t
+ (make-glil-std-prelude nreq nlocs alternate-label))))
+ ;; box args if necessary
+ (for-each
+ (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #t . ,n)
+ (emit-code #f (make-glil-lexical #t #f 'ref n))
+ (emit-code #f (make-glil-lexical #t #t 'box n)))))
+ gensyms)
+ ;; write bindings info
+ (if (not (null? gensyms))
+ (emit-bindings
+ #f
+ (let lp ((kw (if kw (cdr kw) '()))
+ (names (append (reverse opt-names) (reverse req)))
+ (gensyms (list-tail gensyms (+ nreq nopt
+ (if rest 1 0)))))
+ (pmatch kw
+ (()
+ ;; fixme: check that gensyms is empty
+ (reverse (if rest (cons rest names) names)))
+ (((,key ,name ,var) . ,kw)
+ (if (memq var gensyms)
+ (lp kw (cons name names) (delq var gensyms))
+ (lp kw names gensyms)))
+ (,kw (error "bad keywords, yo" kw))))
+ gensyms allocation self emit-code))
+ ;; init optional/kw args
+ (let lp ((inits inits) (n nreq) (gensyms (list-tail gensyms nreq)))
+ (cond
+ ((null? inits)) ; done
+ ((and rest-idx (= n rest-idx))
+ (lp inits (1+ n) (cdr gensyms)))
+ (#t
+ (pmatch (hashq-ref (hashq-ref allocation (car gensyms)) self)
+ ((#t ,boxed? . ,n*) (guard (= n* n))
+ (let ((L (make-label)))
+ (emit-code #f (make-glil-lexical #t boxed? 'bound? n))
+ (emit-code #f (make-glil-branch 'br-if L))
+ (comp-push (car inits))
+ (emit-code #f (make-glil-lexical #t boxed? 'set n))
+ (emit-label L)
+ (lp (cdr inits) (1+ n) (cdr gensyms))))
+ (#t (error "bad arg allocation" (car gensyms) inits))))))
+ ;; post-prelude case label for label calls
+ (emit-label (car (hashq-ref allocation x)))
+ (comp-tail body)
+ (if (not (null? gensyms))
+ (emit-code #f (make-glil-unbind)))
+ (if alternate-label
+ (begin
+ (emit-label alternate-label)
+ (flatten-lambda-case alternate allocation self self-label
+ fix-labels emit-code)))))
+
+ ((<let> src names gensyms vals body)
(for-each comp-push vals)
- (emit-bindings src names vars allocation self emit-code)
+ (emit-bindings src names gensyms allocation self emit-code)
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n)
(emit-code src (make-glil-lexical #t #f 'set n)))
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'box n)))
- (,loc (error "badness" x loc))))
- (reverse vars))
+ (,loc (error "bad let var allocation" x loc))))
+ (reverse gensyms))
(comp-tail body)
+ (clear-stack-slots context gensyms)
(emit-code #f (make-glil-unbind)))
- ((<letrec> src names vars vals body)
+ ((<letrec> src in-order? names gensyms vals body)
+ ;; First prepare heap storage slots.
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'empty-box n)))
- (,loc (error "badness" x loc))))
- vars)
- (for-each comp-push vals)
- (emit-bindings src names vars allocation self emit-code)
- (for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #t . ,n)
- (emit-code src (make-glil-lexical #t #t 'set n)))
- (,loc (error "badness" x loc))))
- (reverse vars))
+ (,loc (error "bad letrec var allocation" x loc))))
+ gensyms)
+ ;; Even though the slots are empty, the bindings are valid.
+ (emit-bindings src names gensyms allocation self emit-code)
+ (cond
+ (in-order?
+ ;; For letrec*, bind values in order.
+ (for-each (lambda (name v val)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #t . ,n)
+ (comp-push val)
+ (emit-code src (make-glil-lexical #t #t 'set n)))
+ (,loc (error "bad letrec var allocation" x loc))))
+ names gensyms vals))
+ (else
+ ;; But for letrec, eval all values, then bind.
+ (for-each comp-push vals)
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'set n)))
+ (,loc (error "bad letrec var allocation" x loc))))
+ (reverse gensyms))))
(comp-tail body)
+ (clear-stack-slots context gensyms)
(emit-code #f (make-glil-unbind)))
- ((<fix> src names vars vals body)
+ ((<fix> src names gensyms vals body)
;; The ideal here is to just render the lambda bodies inline, and
;; wire the code together with gotos. We can do that if
;; analyze-lexicals has determined that a given var has "label"
;; we know the vals are lambdas, we can set them to their local
;; var slots first, then capture their bindings, mutating them in
;; place.
- (let ((RA (if (eq? context 'tail) #f (make-label))))
+ (let ((new-RA (if (or (eq? context 'tail) RA) #f (make-label))))
(for-each
(lambda (x v)
(cond
((hashq-ref allocation x)
;; allocating a closure
(emit-code #f (flatten-lambda x v allocation))
- (if (not (null? (cddr (hashq-ref allocation x))))
- ;; Need to make-closure first, but with a temporary #f
- ;; free-variables vector, so we are mutating fresh
- ;; closures on the heap.
- (begin
- (emit-code #f (make-glil-const #f))
- (emit-code #f (make-glil-call 'make-closure 2))))
+ (let ((free-locs (cdr (hashq-ref allocation x))))
+ (if (not (null? free-locs))
+ ;; Need to make-closure first, so we have a fresh closure on
+ ;; the heap, but with a temporary free values.
+ (begin
+ (for-each (lambda (loc)
+ (emit-code #f (make-glil-const #f)))
+ free-locs)
+ (emit-code #f (make-glil-call 'make-closure
+ (length free-locs))))))
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n)
(emit-code src (make-glil-lexical #t #f 'set n)))
- (,loc (error "badness" x loc))))
+ (,loc (error "bad fix var allocation" x loc))))
(else
;; labels allocation: emit label & body, but jump over it
(let ((POST (make-label)))
(emit-branch #f 'br POST)
- (emit-label v)
- ;; we know the lambda vars are a list
- (emit-bindings #f (lambda-names x) (lambda-vars x)
- allocation self emit-code)
- (if (lambda-src x)
- (emit-code #f (make-glil-source (lambda-src x))))
- (comp-fix (lambda-body x) RA)
- (emit-code #f (make-glil-unbind))
- (emit-label POST)))))
+ (let lp ((lcase (lambda-body x)))
+ (if lcase
+ (record-case lcase
+ ((<lambda-case> src req gensyms body alternate)
+ (emit-label (car (hashq-ref allocation lcase)))
+ ;; FIXME: opt & kw args in the bindings
+ (emit-bindings #f req gensyms allocation self emit-code)
+ (if src
+ (emit-code #f (make-glil-source src)))
+ (comp-fix body (or RA new-RA))
+ (emit-code #f (make-glil-unbind))
+ (lp alternate)))
+ (emit-label POST)))))))
vals
- vars)
+ gensyms)
;; Emit bindings metadata for closures
- (let ((binds (let lp ((out '()) (vars vars) (names names))
- (cond ((null? vars) (reverse! out))
- ((assq (car vars) fix-labels)
- (lp out (cdr vars) (cdr names)))
+ (let ((binds (let lp ((out '()) (gensyms gensyms) (names names))
+ (cond ((null? gensyms) (reverse! out))
+ ((assq (car gensyms) fix-labels)
+ (lp out (cdr gensyms) (cdr names)))
(else
- (lp (acons (car vars) (car names) out)
- (cdr vars) (cdr names)))))))
+ (lp (acons (car gensyms) (car names) out)
+ (cdr gensyms) (cdr names)))))))
(emit-bindings src (map cdr binds) (map car binds)
allocation self emit-code))
;; Now go back and fix up the bindings for closures.
(for-each
(lambda (x v)
(let ((free-locs (if (hashq-ref allocation x)
- (cddr (hashq-ref allocation x))
+ (cdr (hashq-ref allocation x))
;; can hit this latter case for labels allocation
'())))
(if (not (null? free-locs))
(pmatch loc
((,local? ,boxed? . ,n)
(emit-code #f (make-glil-lexical local? #f 'ref n)))
- (else (error "what" x loc))))
+ (else (error "bad free var allocation" x loc))))
free-locs)
- (emit-code #f (make-glil-call 'vector (length free-locs)))
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n)
(emit-code #f (make-glil-lexical #t #f 'fix n)))
- (,loc (error "badness" x loc)))))))
+ (,loc (error "bad fix var allocation" x loc)))))))
vals
- vars)
+ gensyms)
(comp-tail body)
- (emit-label RA)
+ (if new-RA
+ (emit-label new-RA))
+ (clear-stack-slots context gensyms)
(emit-code #f (make-glil-unbind))))
- ((<let-values> src names vars exp body)
- (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
- (cond
- ((pair? inames)
- (lp (cons (car inames) names) (cons (car ivars) vars)
- (cdr inames) (cdr ivars) #f))
- ((not (null? inames))
- (lp (cons inames names) (cons ivars vars) '() '() #t))
- (else
- (let ((names (reverse! names))
- (vars (reverse! vars))
- (MV (make-label)))
- (comp-vals exp MV)
- (emit-code #f (make-glil-const 1))
- (emit-label MV)
- (emit-code src (make-glil-mv-bind
- (vars->bind-list names vars allocation self)
- rest?))
- (for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #f . ,n)
- (emit-code src (make-glil-lexical #t #f 'set n)))
- ((#t #t . ,n)
- (emit-code src (make-glil-lexical #t #t 'box n)))
- (,loc (error "badness" x loc))))
- (reverse vars))
- (comp-tail body)
- (emit-code #f (make-glil-unbind))))))))))
+ ((<let-values> src exp body)
+ (record-case body
+ ((<lambda-case> req opt kw rest gensyms body alternate)
+ (if (or opt kw alternate)
+ (error "unexpected lambda-case in let-values" x))
+ (let ((MV (make-label)))
+ (comp-vals exp MV)
+ (emit-code #f (make-glil-const 1))
+ (emit-label MV)
+ (emit-code src (make-glil-mv-bind
+ (vars->bind-list
+ (append req (if rest (list rest) '()))
+ gensyms allocation self)
+ (and rest #t)))
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'box n)))
+ (,loc (error "bad let-values var allocation" x loc))))
+ (reverse gensyms))
+ (comp-tail body)
+ (clear-stack-slots context gensyms)
+ (emit-code #f (make-glil-unbind))))))
+
+ ;; much trickier than i thought this would be, at first, due to the need
+ ;; to have body's return value(s) on the stack while the unwinder runs,
+ ;; then proceed with returning or dropping or what-have-you, interacting
+ ;; with RA and MVRA. What have you, I say.
+ ((<dynwind> src winder pre body post unwinder)
+ (define (thunk? x)
+ (and (lambda? x)
+ (null? (lambda-case-gensyms (lambda-body x)))))
+ (define (make-wrong-type-arg x)
+ (make-primcall src 'scm-error
+ (list
+ (make-const #f 'wrong-type-arg)
+ (make-const #f "dynamic-wind")
+ (make-const #f "Wrong type (expecting thunk): ~S")
+ (make-primcall #f 'list (list x))
+ (make-primcall #f 'list (list x)))))
+ (define (emit-thunk-check x)
+ (comp-drop (make-conditional
+ src
+ (make-primcall src 'thunk? (list x))
+ (make-void #f)
+ (make-wrong-type-arg x))))
+
+ ;; We know at this point that `winder' and `unwinder' are
+ ;; constant expressions and can be duplicated.
+ (if (not (thunk? winder))
+ (emit-thunk-check winder))
+ (comp-push winder)
+ (if (not (thunk? unwinder))
+ (emit-thunk-check unwinder))
+ (comp-push unwinder)
+ (comp-drop pre)
+ (emit-code #f (make-glil-call 'wind 2))
+
+ (case context
+ ((tail)
+ (let ((MV (make-label)))
+ (comp-vals body MV)
+ ;; one value: unwind...
+ (emit-code #f (make-glil-call 'unwind 0))
+ (comp-drop post)
+ ;; ...and return the val
+ (emit-code #f (make-glil-call 'return 1))
+
+ (emit-label MV)
+ ;; multiple values: unwind...
+ (emit-code #f (make-glil-call 'unwind 0))
+ (comp-drop post)
+ ;; and return the values.
+ (emit-code #f (make-glil-call 'return/nvalues 1))))
+
+ ((push)
+ ;; we only want one value. so ask for one value
+ (comp-push body)
+ ;; and unwind, leaving the val on the stack
+ (emit-code #f (make-glil-call 'unwind 0))
+ (comp-drop post))
+
+ ((vals)
+ (let ((MV (make-label)))
+ (comp-vals body MV)
+ ;; one value: push 1 and fall through to MV case
+ (emit-code #f (make-glil-const 1))
+
+ (emit-label MV)
+ ;; multiple values: unwind...
+ (emit-code #f (make-glil-call 'unwind 0))
+ (comp-drop post)
+ ;; and goto the MVRA.
+ (emit-branch #f 'br MVRA)))
+
+ ((drop)
+ ;; compile body, discarding values. then unwind...
+ (comp-drop body)
+ (emit-code #f (make-glil-call 'unwind 0))
+ (comp-drop post)
+ ;; and fall through, or goto RA if there is one.
+ (if RA
+ (emit-branch #f 'br RA)))))
+
+ ((<dynlet> src fluids vals body)
+ (for-each comp-push fluids)
+ (for-each comp-push vals)
+ (emit-code #f (make-glil-call 'wind-fluids (length fluids)))
+
+ (case context
+ ((tail)
+ (let ((MV (make-label)))
+ ;; NB: in tail case, it is possible to preserve asymptotic tail
+ ;; recursion, via merging unwind-fluids structures -- but we'd need
+ ;; to compile in the body twice (once in tail context, assuming the
+ ;; caller unwinds, and once with this trampoline thing, unwinding
+ ;; ourselves).
+ (comp-vals body MV)
+ ;; one value: unwind and return
+ (emit-code #f (make-glil-call 'unwind-fluids 0))
+ (emit-code #f (make-glil-call 'return 1))
+
+ (emit-label MV)
+ ;; multiple values: unwind and return values
+ (emit-code #f (make-glil-call 'unwind-fluids 0))
+ (emit-code #f (make-glil-call 'return/nvalues 1))))
+
+ ((push)
+ (comp-push body)
+ (emit-code #f (make-glil-call 'unwind-fluids 0)))
+
+ ((vals)
+ (let ((MV (make-label)))
+ (comp-vals body MV)
+ ;; one value: push 1 and fall through to MV case
+ (emit-code #f (make-glil-const 1))
+
+ (emit-label MV)
+ ;; multiple values: unwind and goto MVRA
+ (emit-code #f (make-glil-call 'unwind-fluids 0))
+ (emit-branch #f 'br MVRA)))
+
+ ((drop)
+ ;; compile body, discarding values. then unwind...
+ (comp-drop body)
+ (emit-code #f (make-glil-call 'unwind-fluids 0))
+ ;; and fall through, or goto RA if there is one.
+ (if RA
+ (emit-branch #f 'br RA)))))
+
+ ((<dynref> src fluid)
+ (case context
+ ((drop)
+ (comp-drop fluid))
+ ((push vals tail)
+ (comp-push fluid)
+ (emit-code #f (make-glil-call 'fluid-ref 1))))
+ (maybe-emit-return))
+
+ ((<dynset> src fluid exp)
+ (comp-push fluid)
+ (comp-push exp)
+ (emit-code #f (make-glil-call 'fluid-set 2))
+ (case context
+ ((push vals tail)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ ;; What's the deal here? The deal is that we are compiling the start of a
+ ;; delimited continuation. We try to avoid heap allocation in the normal
+ ;; case; so the body is an expression, not a thunk, and we try to render
+ ;; the handler inline. Also we did some analysis, in analyze.scm, so that
+ ;; if the continuation isn't referenced, we don't reify it. This makes it
+ ;; possible to implement catch and throw with delimited continuations,
+ ;; without any overhead.
+ ((<prompt> src tag body handler)
+ (let ((H (make-label))
+ (POST (make-label))
+ (escape-only? (hashq-ref allocation x)))
+ ;; First, set up the prompt.
+ (comp-push tag)
+ (emit-code src (make-glil-prompt H escape-only?))
+
+ ;; Then we compile the body, with its normal return path, unwinding
+ ;; before proceeding.
+ (case context
+ ((tail)
+ (let ((MV (make-label)))
+ (comp-vals body MV)
+ ;; one value: unwind and return
+ (emit-code #f (make-glil-call 'unwind 0))
+ (emit-code #f (make-glil-call 'return 1))
+ ;; multiple values: unwind and return
+ (emit-label MV)
+ (emit-code #f (make-glil-call 'unwind 0))
+ (emit-code #f (make-glil-call 'return/nvalues 1))))
+
+ ((push)
+ ;; we only want one value. so ask for one value, unwind, and jump to
+ ;; post
+ (comp-push body)
+ (emit-code #f (make-glil-call 'unwind 0))
+ (emit-branch #f 'br (or RA POST)))
+
+ ((vals)
+ (let ((MV (make-label)))
+ (comp-vals body MV)
+ ;; one value: push 1 and fall through to MV case
+ (emit-code #f (make-glil-const 1))
+ ;; multiple values: unwind and goto MVRA
+ (emit-label MV)
+ (emit-code #f (make-glil-call 'unwind 0))
+ (emit-branch #f 'br MVRA)))
+
+ ((drop)
+ ;; compile body, discarding values, then unwind & fall through.
+ (comp-drop body)
+ (emit-code #f (make-glil-call 'unwind 0))
+ (emit-branch #f 'br (or RA POST))))
+
+ (emit-label H)
+ ;; Now the handler. The stack is now made up of the continuation, and
+ ;; then the args to the continuation (pushed separately), and then the
+ ;; number of args, including the continuation.
+ (record-case handler
+ ((<lambda-case> req opt kw rest gensyms body alternate)
+ (if (or opt kw alternate)
+ (error "unexpected lambda-case in prompt" x))
+ (emit-code src (make-glil-mv-bind
+ (vars->bind-list
+ (append req (if rest (list rest) '()))
+ gensyms allocation self)
+ (and rest #t)))
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'box n)))
+ (,loc
+ (error "bad prompt handler arg allocation" x loc))))
+ (reverse gensyms))
+ (comp-tail body)
+ (emit-code #f (make-glil-unbind))))
+
+ (if (and (not RA)
+ (or (eq? context 'push) (eq? context 'drop)))
+ (emit-label POST))))
+
+ ((<abort> src tag args tail)
+ (comp-push tag)
+ (for-each comp-push args)
+ (comp-push tail)
+ (emit-code src (make-glil-call 'abort (length args)))
+ ;; so, the abort can actually return. if it does, the values will be on
+ ;; the stack, then the MV marker, just as in an MV context.
+ (case context
+ ((tail)
+ ;; Return values.
+ (emit-code #f (make-glil-call 'return/nvalues 1)))
+ ((drop)
+ ;; Drop all values and goto RA, or otherwise fall through.
+ (emit-code #f (make-glil-mv-bind 0 #f))
+ (if RA (emit-branch #f 'br RA)))
+ ((push)
+ ;; Truncate to one value.
+ (emit-code #f (make-glil-mv-bind 1 #f)))
+ ((vals)
+ ;; Go to MVRA.
+ (emit-branch #f 'br MVRA)))))))