diff options
author | Andy Wingo <wingo@pobox.com> | 2015-11-26 16:47:17 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-12-01 10:57:20 +0100 |
commit | e5d7c0f13b51b47115d98874c3a3cd51900ba8a3 (patch) | |
tree | d58040505b0aed46afc871eaaa507def3166f5ee /module | |
parent | 02fc5a772bc95bbd70a81b8589bf261a3822f9bd (diff) | |
download | guile-e5d7c0f13b51b47115d98874c3a3cd51900ba8a3.tar.gz |
All arities serialize a "closure" binding
* module/language/cps/compile-bytecode.scm (compile-function): Always
define a 'closure binding in slot 0.
* module/system/vm/frame.scm (available-bindings): No need to futz
around not having a closure binding.
* module/system/vm/debug.scm (arity-arguments-alist): Expect a closure
binding.
* test-suite/tests/rtl.test: Emit definitions for the closure.
Diffstat (limited to 'module')
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 4 | ||||
-rw-r--r-- | module/system/vm/debug.scm | 24 | ||||
-rw-r--r-- | module/system/vm/frame.scm | 4 |
3 files changed, 17 insertions, 15 deletions
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 1c7b99bcc..7fa5a003c 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -472,7 +472,9 @@ (emit-label asm label) (set! frame-size (lookup-nlocals label allocation)) (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys? - frame-size alt))) + frame-size alt) + ;; All arities define a closure binding in slot 0. + (emit-definition asm 'closure 0 'scm))) (($ $kargs names vars ($ $continue k src exp)) (emit-label asm label) (for-each (lambda (name var) diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index 814472b7a..4d9a047fe 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -468,19 +468,21 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}." (flags (arity-flags* bv header)) (nreq (arity-nreq* bv header)) (nopt (arity-nopt* bv header)) - (nargs (+ nreq nopt (if (has-rest? flags) 1 0)))) + (nargs (+ nreq nopt (if (has-rest? flags) 1 0))) + (nargs+closure (1+ nargs))) (when (is-case-lambda? flags) (error "invalid request for locals of case-lambda wrapper arity")) - (let ((args (arity-locals arity nargs))) - (call-with-values (lambda () (split-at args nreq)) - (lambda (req args) - (call-with-values (lambda () (split-at args nopt)) - (lambda (opt args) - `((required . ,req) - (optional . ,opt) - (keyword . ,(arity-keyword-args arity)) - (allow-other-keys? . ,(allow-other-keys? flags)) - (rest . ,(and (has-rest? flags) (car args))))))))))) + (match (arity-locals arity nargs+closure) + ((closure . args) + (call-with-values (lambda () (split-at args nreq)) + (lambda (req args) + (call-with-values (lambda () (split-at args nopt)) + (lambda (opt args) + `((required . ,req) + (optional . ,opt) + (keyword . ,(arity-keyword-args arity)) + (allow-other-keys? . ,(allow-other-keys? flags)) + (rest . ,(and (has-rest? flags) (car args)))))))))))) (define (find-first-arity context base addr) (let* ((bv (elf-bytes (debug-context-elf context))) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 6e4527956..38850b61e 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -277,9 +277,7 @@ (if n (match (vector-ref defs n) (#(name def-offset slot representation) - ;; Binding 0 is the closure, and is not present - ;; in arity-definitions. - (cons (make-binding (1+ n) name slot representation) + (cons (make-binding n name slot representation) (lp (1+ n))))) '())))) (lp (1+ n) (- offset (vector-ref parsed n))))))) |