[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Fix frame-call-representation for callees without
From: |
Andy Wingo |
Subject: |
[Guile-commits] 01/01: Fix frame-call-representation for callees without closures |
Date: |
Wed, 27 Nov 2019 09:06:36 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 7190905109028a43b7471785e05e9a07098e9127
Author: Andy Wingo <address@hidden>
Date: Wed Nov 27 15:04:55 2019 +0100
Fix frame-call-representation for callees without closures
* module/system/vm/assembler.scm (<arity>): Add new "has-closure?"
flag.
(begin-kw-arity, pack-arity-flags, write-arities): Write
"elided-closure?" flag into binary. A negative flag for compat
reasons.
* module/system/vm/debug.scm (elided-closure?, arity-has-closure?): Add
arity-has-closure? accessor.
* module/system/vm/frame.scm (frame-call-representation): Count from 0
for callees with elided closures.
---
module/system/vm/assembler.scm | 20 +++++++++++++++-----
module/system/vm/debug.scm | 4 ++++
module/system/vm/frame.scm | 2 +-
3 files changed, 20 insertions(+), 6 deletions(-)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index da8060a..55417df 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -451,7 +451,7 @@ N-byte unit."
;; Metadata for one <lambda-case>.
(define-record-type <arity>
- (make-arity req opt rest kw-indices allow-other-keys?
+ (make-arity req opt rest kw-indices allow-other-keys? has-closure?
low-pc high-pc definitions)
arity?
(req arity-req)
@@ -459,6 +459,7 @@ N-byte unit."
(rest arity-rest)
(kw-indices arity-kw-indices)
(allow-other-keys? arity-allow-other-keys?)
+ (has-closure? arity-has-closure?)
(low-pc arity-low-pc)
(high-pc arity-high-pc set-arity-high-pc!)
(definitions arity-definitions set-arity-definitions!))
@@ -1499,6 +1500,7 @@ returned instead."
(assert-match alternate (or #f (? exact-integer?) (? symbol?)) "#f or
symbol")
(let* ((meta (car (asm-meta asm)))
(arity (make-arity req opt rest kw-indices allow-other-keys?
+ has-closure?
;; Include the initial instrument-entry in
;; the first arity.
(if (null? (meta-arities meta))
@@ -2243,6 +2245,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be
false. If
;;; #x4: has-keyword-args?
;;; #x8: is-case-lambda?
;;; #x10: is-in-case-lambda?
+;;; #x20: elided-closure?
;;;
;;; Functions with a single arity specify their number of required and
;;; optional arguments in nreq and nopt, and do not have the
@@ -2269,6 +2272,11 @@ procedure with label @var{rw-init}. @var{rw-init} may
be false. If
;;; set. In this way the whole headers array is sorted in increasing
;;; low-pc order, and case-lambda clauses are contained within the
;;; [low-pc, high-pc] of the case-lambda header.
+;;;
+;;; Normally the 0th argument is the closure for the function being
+;;; called. However if the function is "well-known" -- all of its call
+;;; sites are visible -- then the compiler may elide the closure, and
+;;; the 0th argument is the first user-visible argument.
;; Length of the prefix to the arities section, in bytes.
(define arities-prefix-len 4)
@@ -2299,12 +2307,13 @@ procedure with label @var{rw-init}. @var{rw-init} may
be false. If
(define-inline (pack-arity-flags has-rest? allow-other-keys?
has-keyword-args? is-case-lambda?
- is-in-case-lambda?)
+ is-in-case-lambda? elided-closure?)
(logior (if has-rest? (ash 1 0) 0)
(if allow-other-keys? (ash 1 1) 0)
(if has-keyword-args? (ash 1 2) 0)
(if is-case-lambda? (ash 1 3) 0)
- (if is-in-case-lambda? (ash 1 4) 0)))
+ (if is-in-case-lambda? (ash 1 4) 0)
+ (if elided-closure? (ash 1 5) 0)))
(define (write-arities asm metas headers names-port strtab)
(define (write-header pos low-pc high-pc offset flags nreq nopt nlocals)
@@ -2336,7 +2345,8 @@ procedure with label @var{rw-init}. @var{rw-init} may be
false. If
(arity-allow-other-keys? arity)
(pair? (arity-kw-indices arity))
#f
- in-case-lambda?)
+ in-case-lambda?
+ (not (arity-has-closure? arity)))
(length (arity-req arity))
(length (arity-opt arity))
(length (arity-definitions arity)))
@@ -2384,7 +2394,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be
false. If
;; Write a case-lambda header, then individual arities.
;; The case-lambda header's offset link is 0.
(write-header pos (meta-low-pc meta) (meta-high-pc meta) 0
- (pack-arity-flags #f #f #f #t #f) 0 0 0)
+ (pack-arity-flags #f #f #f #t #f #f) 0 0 0)
(let lp* ((arities arities) (pos (+ pos arity-header-len))
(relocs relocs))
(match arities
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index c3b2769..d53048d 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -50,6 +50,7 @@
arity?
arity-low-pc
arity-high-pc
+ arity-has-closure?
arity-nreq
arity-nopt
arity-nlocals
@@ -281,12 +282,14 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
;;; #x4: has-keyword-args?
;;; #x8: is-case-lambda?
;;; #x10: is-in-case-lambda?
+;;; #x20: elided-closure?
(define (has-rest? flags) (not (zero? (logand flags (ash 1 0)))))
(define (allow-other-keys? flags) (not (zero? (logand flags (ash 1 1)))))
(define (has-keyword-args? flags) (not (zero? (logand flags (ash 1 2)))))
(define (is-case-lambda? flags) (not (zero? (logand flags (ash 1 3)))))
(define (is-in-case-lambda? flags) (not (zero? (logand flags (ash 1 4)))))
+(define (elided-closure? flags) (not (zero? (logand flags (ash 1 5)))))
(define (arity-low-pc arity)
(let ((ctx (arity-context arity)))
@@ -318,6 +321,7 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
(arity-flags* (elf-bytes (debug-context-elf (arity-context arity)))
(arity-header-offset arity)))
+(define (arity-has-closure? arity) (not (elided-closure? (arity-flags arity))))
(define (arity-has-rest? arity) (has-rest? (arity-flags arity)))
(define (arity-allow-other-keys? arity) (allow-other-keys? (arity-flags
arity)))
(define (arity-has-keyword-args? arity) (has-keyword-args? (arity-flags
arity)))
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 2b55ce4..47f0e13 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -428,7 +428,7 @@
(arity-nopt arity)
(arity-keyword-args arity)
(arity-has-rest? arity)
- 1))))
+ (if (arity-has-closure? arity) 1 0)))))
((and (primitive-code? ip)
(program-arguments-alist (frame-local-ref frame 0 'scm) ip))
=> (lambda (args)