;;; TREE-IL -> GLIL compiler
-;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001,2008,2009,2010,2011,2012 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))
(define %warning-passes
`((unused-variable . ,unused-variable-analysis)
+ (unused-toplevel . ,unused-toplevel-analysis)
(unbound-variable . ,unbound-variable-analysis)
- (arity-mismatch . ,arity-analysis)))
+ (arity-mismatch . ,arity-analysis)
+ (format . ,format-analysis)))
(define (compile-glil x e opts)
(define warnings
(analyze-tree analyses x e))
(let* ((x (make-lambda (tree-il-src x) '()
- (make-lambda-case #f '() #f #f #f '() '() #f x #f)))
+ (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* e
- (lambda ()
- (values (flatten-lambda x #f allocation)
- 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))
(lambda (emit-code)
;; write source info for proc
(if src (emit-code #f (make-glil-source src)))
- ;; emit pre-prelude label for self tail calls in which the
- ;; number of arguments doesn't check out at compile time
- (if self-label
- (emit-code #f (make-glil-label self-label)))
;; compile the body, yo
- (flatten body allocation x self-label (car (hashq-ref allocation x))
- emit-code)))))))
+ (flatten-lambda-case body allocation x self-label
+ (car (hashq-ref allocation x))
+ emit-code)))))))
-(define (flatten x allocation self self-label fix-labels 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> 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)
- (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))
- ((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)))
- (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 '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))))))
-
- ;; self-call in tail position
+ ;; call to the same lambda-case in tail position
((and (lexical-ref? proc)
self-label (eq? (lexical-ref-gensym proc) self-label)
- (eq? context 'tail))
- ;; first, evaluate new values, pushing them on the stack
+ (eq? context 'tail)
+ (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)
- (let lp ((lcase (lambda-body self)))
- (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
- ;; new box
- (emit-code #f (make-glil-lexical #t #t 'box index)))
- (,x (error "what" x))))
- (reverse (lambda-case-vars lcase)))
- (emit-branch src 'br (car (hashq-ref allocation lcase))))
- ((lambda-case? lcase)
- ;; no match, try next case
- (lp (lambda-case-else lcase)))
- (else
- ;; no cases left; shuffle args down and jump before the prelude.
- (for-each (lambda (i)
- (emit-code #f (make-glil-lexical #t #f 'set i)))
- (reverse (iota (length args))))
- (emit-branch src 'br self-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
+ ;; 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)
(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 "what" x))))
- (reverse (lambda-case-vars lcase)))
+ (,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-else lcase)))
+ (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
(for-each comp-push args)
(let ((len (length args)))
(case context
- ((tail) (emit-code src (make-glil-call 'goto/args len)))
+ ((tail) (emit-code src (make-glil-call 'tail-call len)))
((push) (emit-code src (make-glil-call 'call len))
(maybe-emit-return))
((vals) (emit-code src (make-glil-mv-call len MVRA))
(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))))
((,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 gensym exp)
((,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))))
(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))
- ((<lambda-case> src req opt rest kw inits vars predicate else 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
- ;; vars: (sym ...)
- ;; predicate: tree-il in context of vars
- ;; init: tree-il in context of vars
- ;; vars map to named arguments in the following order:
+ ;; 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))
(kw-indices (map (lambda (x)
(pmatch x
((,key ,name ,var)
- (cons key (list-index vars 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)))
- (else-label (and else (make-label))))
+ (alternate-label (and alternate (make-label))))
(or (= nargs
- (length vars)
+ (length gensyms)
(+ nreq (length inits) (if rest 1 0)))
- (error "something went wrong"
- req opt rest kw inits vars nreq nopt kw-indices nargs))
+ (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
(cond
(kw
(make-glil-kw-prelude nreq nopt rest-idx kw-indices
- allow-other-keys? nlocs else-label))
+ allow-other-keys? nlocs alternate-label))
((or rest opt)
- (make-glil-opt-prelude nreq nopt rest-idx nlocs else-label))
+ (make-glil-opt-prelude nreq nopt rest-idx nlocs alternate-label))
(#t
- (make-glil-std-prelude nreq nlocs else-label))))
+ (make-glil-std-prelude nreq nlocs alternate-label))))
;; box args if necessary
(for-each
(lambda (v)
((#t #t . ,n)
(emit-code #f (make-glil-lexical #t #f 'ref n))
(emit-code #f (make-glil-lexical #t #t 'box n)))))
- vars)
+ gensyms)
;; write bindings info
- (if (not (null? vars))
+ (if (not (null? gensyms))
(emit-bindings
#f
(let lp ((kw (if kw (cdr kw) '()))
(names (append (reverse opt-names) (reverse req)))
- (vars (list-tail vars (+ nreq nopt
+ (gensyms (list-tail gensyms (+ nreq nopt
(if rest 1 0)))))
(pmatch kw
(()
- ;; fixme: check that vars is empty
+ ;; fixme: check that gensyms is empty
(reverse (if rest (cons rest names) names)))
(((,key ,name ,var) . ,kw)
- (if (memq var vars)
- (lp kw (cons name names) (delq var vars))
- (lp kw names vars)))
+ (if (memq var gensyms)
+ (lp kw (cons name names) (delq var gensyms))
+ (lp kw names gensyms)))
(,kw (error "bad keywords, yo" kw))))
- vars allocation self emit-code))
+ gensyms allocation self emit-code))
;; init optional/kw args
- (let lp ((inits inits) (n nreq) (vars (list-tail vars nreq)))
+ (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 vars)))
+ (lp inits (1+ n) (cdr gensyms)))
(#t
- (pmatch (hashq-ref (hashq-ref allocation (car vars)) self)
+ (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))
(comp-push (car inits))
(emit-code #f (make-glil-lexical #t boxed? 'set n))
(emit-label L)
- (lp (cdr inits) (1+ n) (cdr vars))))
- (#t (error "what" inits))))))
+ (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)))
- (if predicate
- (begin
- (comp-push predicate)
- (if else-label
- ;; fixme: debox if necessary
- (emit-branch src 'br-if-not else-label)
- (comp-push (make-application
- src (make-primitive-ref #f 'error)
- (list (make-const #f "precondition not met")))))))
(comp-tail body)
- (if (not (null? vars))
+ (if (not (null? gensyms))
(emit-code #f (make-glil-unbind)))
- (if else-label
+ (if alternate-label
(begin
- (emit-label else-label)
- (comp-tail else)))))
+ (emit-label alternate-label)
+ (flatten-lambda-case alternate allocation self self-label
+ fix-labels emit-code)))))
- ((<let> src names vars vals body)
+ ((<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"
((hashq-ref allocation x)
;; allocating a closure
(emit-code #f (flatten-lambda x v allocation))
- (if (not (null? (cdr (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)))
(let lp ((lcase (lambda-body x)))
(if lcase
(record-case lcase
- ((<lambda-case> src req vars body else)
+ ((<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 vars allocation self emit-code)
+ (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 else)))
+ (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.
(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)
(if new-RA
(emit-label new-RA))
+ (clear-stack-slots context gensyms)
(emit-code #f (make-glil-unbind))))
((<let-values> src exp body)
(record-case body
- ((<lambda-case> req opt kw rest vars predicate body else)
- (if (or opt kw predicate else)
+ ((<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 src (make-glil-mv-bind
(vars->bind-list
(append req (if rest (list rest) '()))
- vars allocation self)
+ gensyms allocation self)
(and rest #t)))
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self)
(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-values var allocation" x loc))))
+ (reverse gensyms))
(comp-tail body)
- (emit-code #f (make-glil-unbind)))))))))
+ (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)))))))