;; allocation:
;; sym -> {lambda -> address}
-;; lambda -> (nlocs . closure-vars)
+;; lambda -> (nlocs labels . free-locs)
;;
;; address := (local? boxed? . index)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
ids
vars))
+;; FIXME: always emit? otherwise it's hard to pair bind with unbind
(define (emit-bindings src ids vars allocation proc emit-code)
(if (pair? vars)
(emit-code src (make-glil-bind
(else (values (reverse (cons ids oids))
(reverse (cons vars ovars))
(1+ n) 1))))
- (let ((nlocs (car (hashq-ref allocation x))))
+ (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
(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 emit-code)))))))
+ (flatten (lambda-body x) allocation x self-label
+ labels emit-code)))))))
-(define (flatten x allocation self self-label emit-code)
+(define (flatten x 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)
(emit-code src (make-glil-branch inst label)))
- ;; LMVRA == "let-values MV return address"
- (let comp ((x x) (context 'tail) (LMVRA #f))
- (define (comp-tail tree) (comp tree context LMVRA))
- (define (comp-push tree) (comp tree 'push #f))
- (define (comp-drop tree) (comp tree 'drop #f))
- (define (comp-vals tree LMVRA) (comp tree 'vals LMVRA))
-
+ ;; 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))
+ (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))
+ (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
+ (define (comp-fix tree RA) (comp tree context RA MVRA))
+
+ ;; A couple of helpers. Note that if we are in tail context, we
+ ;; won't have an RA.
+ (define (maybe-emit-return)
+ (if RA
+ (emit-branch #f 'br RA)
+ (if (eq? context 'tail)
+ (emit-code #f (make-glil-call 'return 1)))))
+
(record-case x
((<void>)
(case context
- ((push vals) (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((push vals tail)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
((<const> src exp)
(case context
- ((push vals) (emit-code src (make-glil-const exp)))
- ((tail)
- (emit-code src (make-glil-const exp))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((push vals tail)
+ (emit-code src (make-glil-const exp))))
+ (maybe-emit-return))
;; FIXME: should represent sequence as exps tail
((<sequence> src exps)
;; drop: (lambda () (apply values '(1 2)) 3)
;; push: (lambda () (list (apply values '(10 12)) 1))
(case context
- ((drop) (for-each comp-drop args))
+ ((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))))))
((push)
(comp-push proc)
(for-each comp-push args)
- (emit-code src (make-glil-call 'apply (1+ (length 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))
- LMVRA))
+ MVRA)
+ (maybe-emit-return))
((drop)
;; Well, shit. The proc might return any number of
;; values (including 0), since it's in a drop context,
;; mv-call out to our trampoline instead.
(comp-drop
(make-application src (make-primitive-ref #f 'apply)
- (cons proc args)))))))))
-
+ (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)))
;; push: (lambda () (list (values '(10 12)) 1))
;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
(case context
- ((drop) (for-each comp-drop args))
+ ((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 LMVRA))
+ (emit-branch src 'br MVRA))
((tail)
(for-each comp-push args)
(emit-code src (make-glil-call 'return/values (length args))))))
(comp-vals
(make-application src (make-primitive-ref #f 'call-with-values)
args)
- LMVRA))
+ MVRA)
+ (maybe-emit-return))
(else
(let ((MV (make-label)) (POST (make-label))
(producer (car args)) (consumer (cadr args)))
(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)))))))))
+ (emit-code #f (make-glil-call 'drop 1)))
+ (maybe-emit-return)))))))
((and (primitive-ref? proc)
(eq? (primitive-ref-name proc) '@call-with-current-continuation)
(make-application
src (make-primitive-ref #f 'call-with-current-continuation)
args)
- LMVRA))
+ MVRA)
+ (maybe-emit-return))
((push)
(comp-push (car args))
- (emit-code src (make-glil-call 'call/cc 1)))
+ (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)))))
+ args))
+ (maybe-emit-return))))
((and (primitive-ref? proc)
(or (hash-ref *primcall-ops*
(case (instruction-pushes op)
((0)
(case context
- ((tail) (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))
- ((push vals) (emit-code #f (make-glil-void)))))
+ ((tail push vals) (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
((1)
(case context
- ((tail) (emit-code #f (make-glil-call 'return 1)))
- ((drop) (emit-code #f (make-glil-call 'drop 1)))))
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
(else
(error "bad primitive op: too many pushes"
op (instruction-pushes op))))))
(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
(emit-code #f (make-glil-lexical #t #f 'set index)))
(,x (error "what" x))))
(reverse (lambda-vars self)))
(emit-branch src 'br self-label))
+ ;; 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
+ (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)))
+
(else
(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)))
- ((vals) (emit-code src (make-glil-mv-call len LMVRA)))
- ((drop)
- (let ((MV (make-label)) (POST (make-label)))
- (emit-code src (make-glil-mv-call len MV))
- (emit-code #f (make-glil-call 'drop 1))
- (emit-branch #f 'br POST)
- (emit-label MV)
- (emit-code #f (make-glil-mv-bind '() #f))
- (emit-code #f (make-glil-unbind))
- (emit-label POST))))))))
+ ((push) (emit-code src (make-glil-call 'call len))
+ (maybe-emit-return))
+ ((vals) (emit-code src (make-glil-mv-call len MVRA))
+ (maybe-emit-return))
+ ((drop) (let ((MV (make-label)) (POST (make-label)))
+ (emit-code src (make-glil-mv-call len MV))
+ (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))
+ (if RA
+ (emit-branch #f 'br RA)
+ (emit-label POST)))))))))
((<conditional> src test then else)
;; TEST
(emit-branch src 'br-if-not L1)
(comp-tail then)
(if (not (eq? context 'tail))
- (emit-branch #f 'br L2))
+ (emit-branch #f 'br (or RA L2)))
(emit-label L1)
(comp-tail else)
(if (not (eq? context 'tail))
- (emit-label L2))))
+ (if RA
+ (emit-branch #f 'br RA)
+ (emit-label L2)))))
((<primitive-ref> src name)
(cond
((eq? (module-variable (fluid-ref *comp-module*) name)
(module-variable the-root-module name))
(case context
- ((push vals)
- (emit-code src (make-glil-toplevel 'ref name)))
- ((tail)
- (emit-code src (make-glil-toplevel 'ref name))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((tail push vals)
+ (emit-code src (make-glil-toplevel 'ref name))))
+ (maybe-emit-return))
(else
(pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
(case context
- ((push vals)
- (emit-code src (make-glil-module 'ref '(guile) name #f)))
- ((tail)
- (emit-code src (make-glil-module 'ref '(guile) name #f))
- (emit-code #f (make-glil-call 'return 1)))))))
+ ((tail push vals)
+ (emit-code src (make-glil-module 'ref '(guile) name #f))))
+ (maybe-emit-return))))
((<lexical-ref> src name gensym)
(case context
(emit-code src (make-glil-lexical local? boxed? 'ref index)))
(,loc
(error "badness" x loc)))))
- (case context
- ((tail) (emit-code #f (make-glil-call 'return 1)))))
+ (maybe-emit-return))
((<lexical-set> src name gensym exp)
(comp-push exp)
(,loc
(error "badness" x loc)))
(case context
- ((push vals)
- (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
((<module-ref> src mod name public?)
(emit-code src (make-glil-module 'ref mod name public?))
(case context
- ((drop) (emit-code #f (make-glil-call 'drop 1)))
- ((tail) (emit-code #f (make-glil-call 'return 1)))))
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
((<module-set> src mod name public? exp)
(comp-push exp)
(emit-code src (make-glil-module 'set mod name public?))
(case context
- ((push vals)
- (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
((<toplevel-ref> src name)
(emit-code src (make-glil-toplevel 'ref name))
(case context
- ((drop) (emit-code #f (make-glil-call 'drop 1)))
- ((tail) (emit-code #f (make-glil-call 'return 1)))))
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
((<toplevel-set> src name exp)
(comp-push exp)
(emit-code src (make-glil-toplevel 'set name))
(case context
- ((push vals)
- (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
((<toplevel-define> src name exp)
(comp-push exp)
(emit-code src (make-glil-toplevel 'define name))
(case context
- ((push vals)
- (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
((<lambda>)
(let ((free-locs (cddr (hashq-ref allocation x))))
(else (error "what" x loc))))
free-locs)
(emit-code #f (make-glil-call 'vector (length free-locs)))
- (emit-code #f (make-glil-call 'make-closure 2))))
- (if (eq? context 'tail)
- (emit-code #f (make-glil-call 'return 1)))))))
+ (emit-code #f (make-glil-call 'make-closure 2)))))))
+ (maybe-emit-return))
((<let> src names vars vals body)
(for-each comp-push vals)
(emit-code #f (make-glil-unbind)))
((<fix> src names vars vals body)
- ;; For fixpoint procedures, we can do some tricks to avoid
- ;; heap-allocation. Since we know the vals are lambdas, we can
- ;; set them to their local var slots first, then capture their
- ;; bindings, mutating them in place.
- (for-each (lambda (x v)
- (emit-code #f (flatten-lambda x v allocation))
- (if (not (null? (cddr (hashq-ref allocation x))))
- ;; But we do have to make-closure them first, 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))))
- (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))))
- vals
- vars)
- (emit-bindings src names vars allocation self emit-code)
- ;; Now go back and fix up the bindings.
- (for-each
- (lambda (x v)
- (let ((free-locs (cddr (hashq-ref allocation x))))
- (if (not (null? free-locs))
- (begin
- (for-each
- (lambda (loc)
- (pmatch loc
- ((,local? ,boxed? . ,n)
- (emit-code #f (make-glil-lexical local? #f 'ref n)))
- (else (error "what" 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)))))))
- vals
- vars)
- (comp-tail body)
- (emit-code #f (make-glil-unbind)))
+ ;; 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"
+ ;; allocation -- which is the case if it is in `fix-labels'.
+ ;;
+ ;; But even for closures that we can't inline, we can do some
+ ;; tricks to avoid heap-allocation for the binding itself. Since
+ ;; 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))))
+ (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))))
+ (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))))
+ (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)))))
+ vals
+ vars)
+ ;; Emit bindings metadata for closures
+ (let ((binds (let lp ((out '()) (vars vars) (names names))
+ (cond ((null? vars) (reverse! out))
+ ((memq (car vars) fix-labels)
+ (lp out (cdr vars) (cdr names)))
+ (else
+ (lp (acons (car vars) (car names) out)
+ (cdr vars) (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))
+ ;; can hit this latter case for labels allocation
+ '())))
+ (if (not (null? free-locs))
+ (begin
+ (for-each
+ (lambda (loc)
+ (pmatch loc
+ ((,local? ,boxed? . ,n)
+ (emit-code #f (make-glil-lexical local? #f 'ref n)))
+ (else (error "what" 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)))))))
+ vals
+ vars)
+ (comp-tail body)
+ (emit-label RA)
+ (emit-code #f (make-glil-unbind))))
((<let-values> src names vars exp body)
(let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
HCoop / bpt / guile.git / blobdiff