From e5d7c0f13b51b47115d98874c3a3cd51900ba8a3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 26 Nov 2015 16:47:17 +0100 Subject: [PATCH] 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. --- module/language/cps/compile-bytecode.scm | 4 +++- module/system/vm/debug.scm | 24 +++++++++++++----------- module/system/vm/frame.scm | 4 +--- test-suite/tests/rtl.test | 17 ++++++++++++++--- 4 files changed, 31 insertions(+), 18 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))))))) diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test index bae76825e..57047a2fb 100644 --- a/test-suite/tests/rtl.test +++ b/test-suite/tests/rtl.test @@ -104,12 +104,13 @@ a procedure." '((begin-program countdown ((name . countdown))) (begin-standard-arity (x) 4 #f) + (definition closure 0 scm) (definition x 1 scm) (br fix-body) (label loop-head) (br-if-= 1 2 #f out) (add 0 1 0) - (add1 1 1) + (add/immediate 1 1 1) (br loop-head) (label fix-body) (load-constant 1 0) @@ -143,6 +144,7 @@ a procedure." (begin-program accum ((name . accum))) (begin-standard-arity (x) 4 #f) + (definition closure 0 scm) (definition x 1 scm) (free-ref 1 3 0) (box-ref 0 1) @@ -164,6 +166,7 @@ a procedure." '((begin-program call ((name . call))) (begin-standard-arity (f) 7 #f) + (definition closure 0 scm) (definition f 1 scm) (mov 1 5) (call 5 1) @@ -179,6 +182,7 @@ a procedure." '((begin-program call-with-3 ((name . call-with-3))) (begin-standard-arity (f) 7 #f) + (definition closure 0 scm) (definition f 1 scm) (mov 1 5) (load-constant 0 3) @@ -196,6 +200,7 @@ a procedure." '((begin-program call ((name . call))) (begin-standard-arity (f) 2 #f) + (definition closure 0 scm) (definition f 1 scm) (mov 1 0) (tail-call 1) @@ -209,6 +214,7 @@ a procedure." '((begin-program call-with-3 ((name . call-with-3))) (begin-standard-arity (f) 2 #f) + (definition closure 0 scm) (definition f 1 scm) (mov 1 0) ;; R0 <- R1 (load-constant 0 3) ;; R1 <- 3 @@ -234,6 +240,7 @@ a procedure." (begin-program sqrt-trampoline ((name . sqrt-trampoline))) (begin-standard-arity (x) 3 #f) + (definition closure 0 scm) (definition x 1 scm) (cached-toplevel-box 0 sqrt-scope sqrt #t) (box-ref 2 0) @@ -264,7 +271,7 @@ a procedure." (begin-standard-arity () 3 #f) (cached-toplevel-box 1 top-incrementor *top-val* #t) (box-ref 0 1) - (add1 0 0) + (add/immediate 0 0 1) (box-set! 1 0) (return-values 1) (end-arity) @@ -287,6 +294,7 @@ a procedure." (begin-program sqrt-trampoline ((name . sqrt-trampoline))) (begin-standard-arity (x) 3 #f) + (definition closure 0 scm) (definition x 1 scm) (cached-module-box 0 (guile) sqrt #t #t) (box-ref 2 0) @@ -313,7 +321,7 @@ a procedure." (begin-standard-arity () 3 #f) (cached-module-box 1 (tests bytecode) *top-val* #f #t) (box-ref 0 1) - (add1 0 0) + (add/immediate 0 0 1) (box-set! 1 0) (mov 1 0) (return-values 2) @@ -359,6 +367,7 @@ a procedure." (assemble-program '((begin-program foo ((name . foo))) (begin-standard-arity () 2 #f) + (definition closure 0 scm) (load-constant 0 42) (return-values 2) (end-arity) @@ -368,6 +377,7 @@ a procedure." (assemble-program '((begin-program foo ((name . foo))) (begin-standard-arity (x y) 3 #f) + (definition closure 0 scm) (definition x 1 scm) (definition y 2 scm) (load-constant 1 42) @@ -380,6 +390,7 @@ a procedure." (assemble-program '((begin-program foo ((name . foo))) (begin-opt-arity (x) (y) z 4 #f) + (definition closure 0 scm) (definition x 1 scm) (definition y 2 scm) (definition z 3 scm)