[Guile-commits] 01/01: Fix frame-call-representation for callees without closures

[Andy Wingo]

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)