[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-932-g67ddb7e
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-932-g67ddb7e |
|
Date: |
Tue, 15 Apr 2014 18:33:03 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=67ddb7e264bbc53a9b121bb21dc521651a15b205
The branch, master has been updated
via 67ddb7e264bbc53a9b121bb21dc521651a15b205 (commit)
via 1a82c2012b2ef77438b96fdd1e03e5f642286043 (commit)
via c3651bd55b3e7f37e6ef3171e8b305246cf45aec (commit)
via cade4c8fe15dda3978e8874fe5ec07414070c432 (commit)
via 78351d1065627d10aa8dde8d5c6424d83233dfc4 (commit)
via 863034a8ac4e23118e367b7f3ca4d9e06112902c (commit)
via 21a528fd8260bd92c9bed0ade1198f854abe62dd (commit)
via bec786c1fecd79c37d82cf263eef8e49bb1bf717 (commit)
from da169db26ae3ac4c2440b1fcb678cfd18392c5aa (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 67ddb7e264bbc53a9b121bb21dc521651a15b205
Author: Andy Wingo <address@hidden>
Date: Tue Apr 15 20:25:16 2014 +0200
Assembler residualizes local variable definition locations
* module/system/vm/assembler.scm (write-arities): Serialize definition
locations after names.
(definition): Store definition as a byte offset.
commit 1a82c2012b2ef77438b96fdd1e03e5f642286043
Author: Andy Wingo <address@hidden>
Date: Tue Apr 15 20:20:01 2014 +0200
Bump minor objcode version for recent changes
* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION):
* module/system/vm/assembler.scm (*bytecode-minor-version*): Bump.
commit c3651bd55b3e7f37e6ef3171e8b305246cf45aec
Author: Andy Wingo <address@hidden>
Date: Tue Apr 15 17:52:41 2014 +0200
Write all local variable names into the arities section
* module/system/vm/assembler.scm (put-uleb128, put-sleb128)
(port-position): Lift out these helpers.
(arity-header-len, write-arities, link-arities): Add "nlocals" to the
arity headers. Write names of all locals into the arities section,
not just the arguments. Write them as uleb128's instead of uint32's,
to save space.
* module/system/vm/debug.scm (arity-header-len, arity-nlocals*)
(arity-nlocals, arity-locals, arity-arguments-alist): Adapt to new
encoding for arities.
commit cade4c8fe15dda3978e8874fe5ec07414070c432
Author: Andy Wingo <address@hidden>
Date: Tue Apr 15 15:27:19 2014 +0200
Tweak arities debugging representation
* module/system/vm/assembler.scm (meta-arities-size, write-arity-links):
* module/system/vm/debug.scm (arity-keyword-args)
(arity-arguments-alist): Rewrite to put they keyword literals link
first. Unfortunately requires a recompile :/
commit 78351d1065627d10aa8dde8d5c6424d83233dfc4
Author: Andy Wingo <address@hidden>
Date: Tue Apr 15 14:02:25 2014 +0200
Beginnings of local variable information
* module/system/vm/assembler.scm (<arity>, begin-kw-arity, end-arity):
(definition): Add definition macro-instruction. Arrange to record
variable definitions.
* module/language/cps/compile-bytecode.scm (compile-fun): Emit
definition macro-instructions as appropriate.
commit 863034a8ac4e23118e367b7f3ca4d9e06112902c
Author: Andy Wingo <address@hidden>
Date: Tue Apr 15 12:25:26 2014 +0200
Remove needless label remapping in slot-allocation
* module/language/cps/slot-allocation.scm (dead-after-def?):
(dead-after-use?, allocate-slots): Remove some needless remapping
between label indexes in the CFA, the DFA, and their names.
commit 21a528fd8260bd92c9bed0ade1198f854abe62dd
Author: Andy Wingo <address@hidden>
Date: Tue Apr 15 12:16:41 2014 +0200
DFA datums don't rename their labels
* module/language/cps/dfg.scm (analyze-reverse-control-flow): Don't
compute and return an order vector; it's not needed.
($dfa): Remove label renaming. We can just rename labels before
returning the DFA.
(dfa-k-idx, dfa-k-sym, dfa-k-count): Adapt.
(compute-live-variables): Adapt, and rename labels before returning.
commit bec786c1fecd79c37d82cf263eef8e49bb1bf717
Author: Andy Wingo <address@hidden>
Date: Tue Apr 15 11:18:50 2014 +0200
Better backtraces for optimized closures
* module/system/vm/debug.scm (arity-keyword-args, find-program-arity):
New exports.
* module/system/vm/frame.scm (frame-call-representation): Prefer to use
the frame IP to get the procedure.
-----------------------------------------------------------------------
Summary of changes:
libguile/_scm.h | 2 +-
module/language/cps/compile-bytecode.scm | 7 +-
module/language/cps/dfg.scm | 81 +++++-----
module/language/cps/slot-allocation.scm | 27 +--
module/system/vm/assembler.scm | 273 +++++++++++++++---------------
module/system/vm/debug.scm | 124 +++++++++++---
module/system/vm/frame.scm | 75 +++++----
7 files changed, 330 insertions(+), 259 deletions(-)
diff --git a/libguile/_scm.h b/libguile/_scm.h
index 003c36d..87f9763 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -268,7 +268,7 @@ void scm_ia64_longjmp (scm_i_jmp_buf *, int);
/* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 3
-#define SCM_OBJCODE_MINOR_VERSION 4
+#define SCM_OBJCODE_MINOR_VERSION 5
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index e3e31a0..fc4b21a 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -153,8 +153,13 @@
label
(match (lookup-cont label dfg)
(($ $kclause) label)
- (($ $kargs _ _ term)
+ (($ $kargs names vars term)
(emit-label asm label)
+ (for-each (lambda (name var)
+ (let ((slot (maybe-slot var)))
+ (when slot
+ (emit-definition asm name slot))))
+ names vars)
(let find-exp ((term term))
(match term
(($ $letk conts term)
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 6bc8d5a..e48fe5e 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -269,8 +269,7 @@ body continuation in the prompt."
(define (analyze-reverse-control-flow fun dfg min-label label-count)
(define (compute-reverse-control-flow-order ktail dfg)
- (let ((order (make-vector label-count #f))
- (label-map (make-vector label-count #f))
+ (let ((label-map (make-vector label-count #f))
(next -1))
(define (label->idx label) (- label min-label))
(define (idx->label idx) (+ idx min-label))
@@ -304,12 +303,7 @@ body continuation in the prompt."
(vector-set! label-map (label->idx head) n)
(lp (1+ n) next))))
- (let lp ((n 0))
- (when (< n label-count)
- (vector-set! order (vector-ref label-map n) (idx->label n))
- (lp (1+ n))))
-
- (values order label-map)))
+ label-map))
(define (convert-successors k-map)
(define (idx->label idx) (+ idx min-label))
@@ -326,24 +320,21 @@ body continuation in the prompt."
(match fun
(($ $cont kfun ($ $kfun src meta self ($ $cont ktail tail)))
- (call-with-values
- (lambda ()
- (compute-reverse-control-flow-order ktail dfg))
- (lambda (order k-map)
- (let ((succs (convert-successors k-map)))
- ;; Any expression in the prompt body could cause an abort to
- ;; the handler. This code adds links from every block in the
- ;; prompt body to the handler. This causes all values used
- ;; by the handler to be seen as live in the prompt body, as
- ;; indeed they are.
- (visit-prompt-control-flow
- dfg min-label label-count
- (lambda (prompt handler body)
- (define (renumber label)
- (vector-ref k-map (- label min-label)))
- (vector-push! succs (renumber body) (renumber handler))))
-
- (values k-map order succs)))))))
+ (let* ((k-map (compute-reverse-control-flow-order ktail dfg))
+ (succs (convert-successors k-map)))
+ ;; Any expression in the prompt body could cause an abort to
+ ;; the handler. This code adds links from every block in the
+ ;; prompt body to the handler. This causes all values used
+ ;; by the handler to be seen as live in the prompt body, as
+ ;; indeed they are.
+ (visit-prompt-control-flow
+ dfg min-label label-count
+ (lambda (prompt handler body)
+ (define (renumber label)
+ (vector-ref k-map (- label min-label)))
+ (vector-push! succs (renumber body) (renumber handler))))
+
+ (values k-map succs)))))
;; Dominator analysis.
(define-record-type $dominator-analysis
@@ -616,18 +607,13 @@ body continuation in the prompt."
;; Data-flow analysis.
(define-record-type $dfa
- (make-dfa min-label k-map k-order min-var var-count in out)
+ (make-dfa min-label min-var var-count in out)
dfa?
- ;; Minimum label.
+ ;; Minimum label in this function.
(min-label dfa-min-label)
- ;; Vector of (k - min-label) -> k-idx
- (k-map dfa-k-map)
- ;; Vector of k-idx -> k-sym, in (possibly reversed) control-flow order
- (k-order dfa-k-order)
-
;; Minimum var in this function.
(min-var dfa-min-var)
- ;; Minimum var in this function.
+ ;; Var count in this function.
(var-count dfa-var-count)
;; Vector of k-idx -> bitvector
(in dfa-in)
@@ -635,13 +621,13 @@ body continuation in the prompt."
(out dfa-out))
(define (dfa-k-idx dfa k)
- (vector-ref (dfa-k-map dfa) (- k (dfa-min-label dfa))))
+ (- k (dfa-min-label dfa)))
(define (dfa-k-sym dfa idx)
- (vector-ref (dfa-k-order dfa) idx))
+ (+ idx (dfa-min-label dfa)))
(define (dfa-k-count dfa)
- (vector-length (dfa-k-map dfa)))
+ (vector-length (dfa-in dfa)))
(define (dfa-var-idx dfa var)
(let ((idx (- var (dfa-min-var dfa))))
@@ -675,7 +661,7 @@ body continuation in the prompt."
(call-with-values
(lambda ()
(analyze-reverse-control-flow fun dfg min-label nlabels))
- (lambda (k-map k-order succs)
+ (lambda (k-map succs)
(define (var->idx var) (- var min-var))
(define (idx->var idx) (+ idx min-var))
(define (label->idx label)
@@ -710,11 +696,22 @@ body continuation in the prompt."
;; predecessors. Continuation 0 is ktail.
(compute-maximum-fixed-point succs live-out live-in defv usev #t)
- (make-dfa min-label k-map k-order min-var nvars live-in live-out)))))
+ ;; Now rewrite the live-in and live-out sets to be indexed by
+ ;; (LABEL - MIN-LABEL).
+ (let ((live-in* (make-vector nlabels #f))
+ (live-out* (make-vector nlabels #f)))
+ (let lp ((idx 0))
+ (when (< idx nlabels)
+ (let ((dfa-idx (vector-ref k-map idx)))
+ (vector-set! live-in* idx (vector-ref live-in dfa-idx))
+ (vector-set! live-out* idx (vector-ref live-out dfa-idx))
+ (lp (1+ idx)))))
+
+ (make-dfa min-label min-var nvars live-in* live-out*))))))
(define (print-dfa dfa)
(match dfa
- (($ $dfa min-label k-map k-order min-var var-count in out)
+ (($ $dfa min-label min-var var-count in out)
(define (print-var-set bv)
(let lp ((n 0))
(let ((n (bit-position #t bv n)))
@@ -722,8 +719,8 @@ body continuation in the prompt."
(format #t " ~A" (+ n min-var))
(lp (1+ n))))))
(let lp ((n 0))
- (when (< n (vector-length k-order))
- (format #t "~A:\n" (vector-ref k-order n))
+ (when (< n (vector-length in))
+ (format #t "~A:\n" (+ n min-label))
(format #t " in:")
(print-var-set (vector-ref in n))
(newline)
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index 47e6284..3d5183e 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -223,13 +223,11 @@ are comparable with eqv?. A tmp slot may be used."
tmp)
(loop to-move b (cons s+d moved) last-source))))))))))
-(define (dead-after-def? def-k v-idx dfa)
- (let ((l (dfa-k-idx dfa def-k)))
- (not (bitvector-ref (dfa-k-in dfa l) v-idx))))
+(define (dead-after-def? k-idx v-idx dfa)
+ (not (bitvector-ref (dfa-k-in dfa k-idx) v-idx)))
-(define (dead-after-use? use-k v-idx dfa)
- (let ((l (dfa-k-idx dfa use-k)))
- (not (bitvector-ref (dfa-k-out dfa l) v-idx))))
+(define (dead-after-use? k-idx v-idx dfa)
+ (not (bitvector-ref (dfa-k-out dfa k-idx) v-idx)))
(define (allocate-slots fun dfg)
(let* ((dfa (compute-live-variables fun dfg))
@@ -275,7 +273,7 @@ are comparable with eqv?. A tmp slot may be used."
(1- (find-first-trailing-zero live-slots)))
(define (recompute-live-slots k nargs)
- (let ((in (dfa-k-in dfa (dfa-k-idx dfa k))))
+ (let ((in (dfa-k-in dfa (label->idx k))))
(let lp ((v 0) (live-slots (1- (ash 1 (1+ nargs)))))
(let ((v (bit-position #t in v)))
(if v
@@ -384,7 +382,7 @@ are comparable with eqv?. A tmp slot may be used."
;; predecessor.
((or (_) ((? kreceive-get-kargs) ...))
(for-each (lambda (var)
- (when (dead-after-def? (idx->label n) var dfa)
+ (when (dead-after-def? n var dfa)
(bitvector-set! needs-slotv var #f)))
(vector-ref defv n)))
(_ #f))
@@ -399,17 +397,10 @@ are comparable with eqv?. A tmp slot may be used."
;; frames as soon as it's known that a call will happen. It would
;; be nice to recast this as a proper data-flow problem.
(define (compute-needs-hint!)
- ;; We traverse the graph using reverse-post-order on a forward
- ;; control-flow graph, but we did the live variable analysis in
- ;; the opposite direction -- so the continuation numbers don't
- ;; correspond. This helper adapts them.
- (define (label-idx->dfa-k-idx n)
- (dfa-k-idx dfa (idx->label n)))
-
(define (live-before n)
- (dfa-k-in dfa (label-idx->dfa-k-idx n)))
+ (dfa-k-in dfa n))
(define (live-after n)
- (dfa-k-out dfa (label-idx->dfa-k-idx n)))
+ (dfa-k-out dfa n))
;; Walk backwards. At a call, compute the set of variables that
;; have allocated slots and are live before but not after. This
@@ -611,7 +602,7 @@ are comparable with eqv?. A tmp slot may be used."
(let ((slot (vector-ref slots v)))
(if (and slot
(> slot nargs)
- (pred (idx->label n) v dfa))
+ (pred n v dfa))
(kill-dead-slot slot live)
live)))
live
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 7f4b1bd..bed2bf7 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -163,7 +163,7 @@
;; Metadata for one <lambda-case>.
(define-record-type <arity>
(make-arity req opt rest kw-indices allow-other-keys?
- low-pc high-pc)
+ low-pc high-pc definitions)
arity?
(req arity-req)
(opt arity-opt)
@@ -171,7 +171,8 @@
(kw-indices arity-kw-indices)
(allow-other-keys? arity-allow-other-keys?)
(low-pc arity-low-pc)
- (high-pc arity-high-pc set-arity-high-pc!))
+ (high-pc arity-high-pc set-arity-high-pc!)
+ (definitions arity-definitions set-arity-definitions!))
(define-syntax *block-size* (identifier-syntax 32))
@@ -753,7 +754,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?
- (asm-start asm) #f))
+ (asm-start asm) #f '()))
;; The procedure itself is in slot 0, in the standard calling
;; convention. For procedure prologues, nreq includes the
;; procedure, so here we add 1.
@@ -772,6 +773,7 @@ returned instead."
(define-macro-assembler (end-arity asm)
(let ((arity (car (meta-arities (car (asm-meta asm))))))
+ (set-arity-definitions! arity (reverse (arity-definitions arity)))
(set-arity-high-pc! arity (asm-start asm))))
(define-macro-assembler (standard-prelude asm nreq nlocals alternate)
@@ -825,6 +827,13 @@ returned instead."
(define-macro-assembler (source asm source)
(set-asm-sources! asm (acons (asm-start asm) source (asm-sources asm))))
+(define-macro-assembler (definition asm name slot)
+ (let* ((arity (car (meta-arities (car (asm-meta asm)))))
+ (def (vector name
+ slot
+ (* (- (asm-start asm) (arity-low-pc arity)) 4))))
+ (set-arity-definitions! arity (cons def (arity-definitions arity)))))
+
(define-macro-assembler (cache-current-module! asm module scope)
(let ((mod-label (intern-module-cache-cell asm scope)))
(emit-static-set! asm module mod-label 0)))
@@ -1281,7 +1290,7 @@ needed."
;; FIXME: Define these somewhere central, shared with C.
(define *bytecode-major-version* #x0202)
-(define *bytecode-minor-version* 4)
+(define *bytecode-minor-version* 5)
(define (link-dynamic-section asm text rw rw-init frame-maps)
"Link the dynamic section for an ELF image with bytecode @var{text},
@@ -1392,6 +1401,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be
false. If
;;; uint32_t flags;
;;; uint32_t nreq;
;;; uint32_t nopt;
+;;; uint32_t nlocals;
;;; }
;;;
;;; All of the offsets and addresses are 32 bits. We can expand in the
@@ -1412,12 +1422,15 @@ procedure with label @var{rw-init}. @var{rw-init} may
be false. If
;;; is-case-lambda? flag set. Their "offset" member links to an array
;;; of pointers into the associated .guile.arities.strtab string table,
;;; identifying the argument names. This offset is relative to the
-;;; start of the .guile.arities section. Links for required arguments
-;;; are first, in order, as uint32 values. Next follow the optionals,
-;;; then the rest link if has-rest? is set, then a link to the "keyword
-;;; indices" literal if has-keyword-args? is set. Unlike the other
-;;; links, the kw-indices link points into the data section, and is
-;;; relative to the ELF image as a whole.
+;;; start of the .guile.arities section.
+;;;
+;;; If the arity has keyword arguments -- if has-keyword-args? is set in
+;;; the flags -- the first uint32 pointed to by offset encodes a link to
+;;; the "keyword indices" literal, in the data section. Then follow the
+;;; names for all locals, in order, as uleb128 values. The required
+;;; arguments will be the first locals, followed by the optionals,
+;;; followed by the rest argument if if has-rest? is set. The names
+;;; point into the associated string table section.
;;;
;;; Functions with no arities have no arities information present in the
;;; .guile.arities section.
@@ -1434,10 +1447,28 @@ procedure with label @var{rw-init}. @var{rw-init} may
be false. If
(define arities-prefix-len 4)
;; Length of an arity header, in bytes.
-(define arity-header-len (* 6 4))
+(define arity-header-len (* 7 4))
+
+;; Some helpers.
+(define (put-uleb128 port val)
+ (let lp ((val val))
+ (let ((next (ash val -7)))
+ (if (zero? next)
+ (put-u8 port val)
+ (begin
+ (put-u8 port (logior #x80 (logand val #x7f)))
+ (lp next))))))
+
+(define (put-sleb128 port val)
+ (let lp ((val val))
+ (if (<= 0 (+ val 64) 127)
+ (put-u8 port (logand val #x7f))
+ (begin
+ (put-u8 port (logior #x80 (logand val #x7f)))
+ (lp (ash val -7))))))
-;; The offset of "offset" within arity header, in bytes.
-(define arity-header-offset-offset (* 2 4))
+(define (port-position port)
+ (seek port 0 SEEK_CUR))
(define-syntax-rule (pack-arity-flags has-rest? allow-other-keys?
has-keyword-args? is-case-lambda?
@@ -1448,127 +1479,123 @@ procedure with label @var{rw-init}. @var{rw-init}
may be false. If
(if is-case-lambda? (ash 1 3) 0)
(if is-in-case-lambda? (ash 1 4) 0)))
-(define (meta-arities-size meta)
- (define (lambda-size arity)
- (+ arity-header-len
- (* 4 ;; name pointers
- (+ (length (arity-req arity))
- (length (arity-opt arity))
- (if (arity-rest arity) 1 0)
- (if (pair? (arity-kw-indices arity)) 1 0)))))
- (define (case-lambda-size arities)
- (fold +
- arity-header-len ;; case-lambda header
- (map lambda-size arities))) ;; the cases
- (match (meta-arities meta)
- (() 0)
- ((arity) (lambda-size arity))
- (arities (case-lambda-size arities))))
-
-(define (write-arity-headers metas bv endianness)
- (define (write-arity-header* pos low-pc high-pc flags nreq nopt)
- (bytevector-u32-set! bv pos (* low-pc 4) endianness)
- (bytevector-u32-set! bv (+ pos 4) (* high-pc 4) endianness)
- (bytevector-u32-set! bv (+ pos 8) 0 endianness) ; offset
- (bytevector-u32-set! bv (+ pos 12) flags endianness)
- (bytevector-u32-set! bv (+ pos 16) nreq endianness)
- (bytevector-u32-set! bv (+ pos 20) nopt endianness))
- (define (write-arity-header pos arity in-case-lambda?)
- (write-arity-header* pos (arity-low-pc arity)
- (arity-high-pc arity)
- (pack-arity-flags (arity-rest arity)
- (arity-allow-other-keys? arity)
- (pair? (arity-kw-indices arity))
- #f
- in-case-lambda?)
- (length (arity-req arity))
- (length (arity-opt arity))))
- (let lp ((metas metas) (pos arities-prefix-len) (offsets '()))
+(define (write-arities asm metas headers names-port strtab)
+ (define (write-header pos low-pc high-pc offset flags nreq nopt nlocals)
+ (bytevector-u32-set! headers pos (* low-pc 4) (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 4) (* high-pc 4) (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 8) offset (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 12) flags (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 16) nreq (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 20) nopt (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 24) nlocals (asm-endianness asm)))
+ (define (write-kw-indices kw-indices relocs)
+ ;; FIXME: Assert that kw-indices is already interned.
+ (if (pair? kw-indices)
+ (let ((pos (+ (bytevector-length headers)
+ (port-position names-port)))
+ (label (intern-constant asm kw-indices)))
+ (put-bytevector names-port #vu8(0 0 0 0))
+ (cons (make-linker-reloc 'abs32/1 pos 0 label) relocs))
+ relocs))
+ (define (write-arity pos arity in-case-lambda? relocs)
+ (write-header pos (arity-low-pc arity)
+ (arity-high-pc arity)
+ ;; FIXME: Seems silly to add on bytevector-length of
+ ;; headers, given the arities-prefix.
+ (+ (bytevector-length headers) (port-position names-port))
+ (pack-arity-flags (arity-rest arity)
+ (arity-allow-other-keys? arity)
+ (pair? (arity-kw-indices arity))
+ #f
+ in-case-lambda?)
+ (length (arity-req arity))
+ (length (arity-opt arity))
+ (length (arity-definitions arity)))
+ (let ((relocs (write-kw-indices (arity-kw-indices arity) relocs)))
+ ;; Write local names.
+ (let lp ((definitions (arity-definitions arity)))
+ (match definitions
+ (() relocs)
+ ((#(name slot def) . definitions)
+ (let ((sym (if (symbol? name)
+ (string-table-intern! strtab (symbol->string name))
+ 0)))
+ (put-uleb128 names-port sym)
+ (lp definitions)))))
+ ;; Now write their definitions.
+ (let lp ((definitions (arity-definitions arity)))
+ (match definitions
+ (() relocs)
+ ((#(name slot def) . definitions)
+ (put-uleb128 names-port def)
+ (put-uleb128 names-port slot)
+ (lp definitions))))))
+ (let lp ((metas metas) (pos arities-prefix-len) (relocs '()))
(match metas
(()
- ;; Fill in the prefix.
- (bytevector-u32-set! bv 0 pos endianness)
- (values pos (reverse offsets)))
+ (unless (= pos (bytevector-length headers))
+ (error "expected to fully fill the bytevector"
+ pos (bytevector-length headers)))
+ relocs)
((meta . metas)
(match (meta-arities meta)
- (() (lp metas pos offsets))
+ (() (lp metas pos relocs))
((arity)
- (write-arity-header pos arity #f)
(lp metas
(+ pos arity-header-len)
- (acons arity (+ pos arity-header-offset-offset) offsets)))
+ (write-arity pos arity #f relocs)))
(arities
;; Write a case-lambda header, then individual arities.
;; The case-lambda header's offset link is 0.
- (write-arity-header* pos (meta-low-pc meta) (meta-high-pc meta)
- (pack-arity-flags #f #f #f #t #f) 0 0)
+ (write-header pos (meta-low-pc meta) (meta-high-pc meta) 0
+ (pack-arity-flags #f #f #f #t #f) 0 0 0)
(let lp* ((arities arities) (pos (+ pos arity-header-len))
- (offsets offsets))
+ (relocs relocs))
(match arities
- (() (lp metas pos offsets))
+ (() (lp metas pos relocs))
((arity . arities)
- (write-arity-header pos arity #t)
(lp* arities
(+ pos arity-header-len)
- (acons arity
- (+ pos arity-header-offset-offset)
- offsets)))))))))))
-
-(define (write-arity-links asm bv pos arity-offset-pairs strtab)
- (define (write-symbol sym pos)
- (bytevector-u32-set! bv pos
- (string-table-intern! strtab (symbol->string sym))
- (asm-endianness asm))
- (+ pos 4))
- (define (write-kw-indices pos kw-indices)
- ;; FIXME: Assert that kw-indices is already interned.
- (make-linker-reloc 'abs32/1 pos 0
- (intern-constant asm kw-indices)))
- (let lp ((pos pos) (pairs arity-offset-pairs) (relocs '()))
- (match pairs
- (()
- (unless (= pos (bytevector-length bv))
- (error "expected to fully fill the bytevector"
- pos (bytevector-length bv)))
- relocs)
- (((arity . offset) . pairs)
- (bytevector-u32-set! bv offset pos (asm-endianness asm))
- (let ((pos (fold write-symbol
- pos
- (append (arity-req arity)
- (arity-opt arity)
- (cond
- ((arity-rest arity) => list)
- (else '()))))))
- (match (arity-kw-indices arity)
- (() (lp pos pairs relocs))
- (kw-indices
- (lp (+ pos 4)
- pairs
- (cons (write-kw-indices pos kw-indices) relocs)))))))))
+ (write-arity pos arity #t relocs)))))))))))
(define (link-arities asm)
+ (define (meta-arities-header-size meta)
+ (define (lambda-size arity)
+ arity-header-len)
+ (define (case-lambda-size arities)
+ (fold +
+ arity-header-len ;; case-lambda header
+ (map lambda-size arities))) ;; the cases
+ (match (meta-arities meta)
+ (() 0)
+ ((arity) (lambda-size arity))
+ (arities (case-lambda-size arities))))
+
+ (define (bytevector-append a b)
+ (let ((out (make-bytevector (+ (bytevector-length a)
+ (bytevector-length b)))))
+ (bytevector-copy! a 0 out 0 (bytevector-length a))
+ (bytevector-copy! b 0 out (bytevector-length a) (bytevector-length b))
+ out))
+
(let* ((endianness (asm-endianness asm))
(metas (reverse (asm-meta asm)))
- (size (fold (lambda (meta size)
- (+ size (meta-arities-size meta)))
- arities-prefix-len
- metas))
+ (header-size (fold (lambda (meta size)
+ (+ size (meta-arities-header-size meta)))
+ arities-prefix-len
+ metas))
(strtab (make-string-table))
- (bv (make-bytevector size 0)))
- (let ((kw-indices-relocs
- (call-with-values
- (lambda ()
- (write-arity-headers metas bv endianness))
- (lambda (pos arity-offset-pairs)
- (write-arity-links asm bv pos arity-offset-pairs strtab)))))
- (let ((strtab (make-object asm '.guile.arities.strtab
- (link-string-table! strtab)
- '() '()
- #:type SHT_STRTAB #:flags 0)))
+ (headers (make-bytevector header-size 0)))
+ (bytevector-u32-set! headers 0 (bytevector-length headers) endianness)
+ (let-values (((names-port get-name-bv) (open-bytevector-output-port)))
+ (let* ((relocs (write-arities asm metas headers names-port strtab))
+ (strtab (make-object asm '.guile.arities.strtab
+ (link-string-table! strtab)
+ '() '()
+ #:type SHT_STRTAB #:flags 0)))
(values (make-object asm '.guile.arities
- bv
- kw-indices-relocs '()
+ (bytevector-append headers (get-name-bv))
+ relocs '()
#:type SHT_PROGBITS #:flags 0
#:link (elf-section-index
(linker-object-section strtab)))
@@ -1715,26 +1742,6 @@ procedure with label @var{rw-init}. @var{rw-init} may
be false. If
(bytevector-u64-set! bv 0 val (asm-endianness asm))
(put-bytevector port bv)))
- (define (put-uleb128 port val)
- (let lp ((val val))
- (let ((next (ash val -7)))
- (if (zero? next)
- (put-u8 port val)
- (begin
- (put-u8 port (logior #x80 (logand val #x7f)))
- (lp next))))))
-
- (define (put-sleb128 port val)
- (let lp ((val val))
- (if (<= 0 (+ val 64) 127)
- (put-u8 port (logand val #x7f))
- (begin
- (put-u8 port (logior #x80 (logand val #x7f)))
- (lp (ash val -7))))))
-
- (define (port-position port)
- (seek port 0 SEEK_CUR))
-
(define (meta->subprogram-die meta)
`(subprogram
(@ ,@(cond
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index b4dfc3e..ac2041c 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -1,6 +1,6 @@
;;; Guile runtime debug information
-;;; Copyright (C) 2013 Free Software Foundation, Inc.
+;;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -31,7 +31,7 @@
#:use-module (system foreign)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
- #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module ((srfi srfi-1) #:select (fold split-at))
#:use-module (srfi srfi-9)
#:export (debug-context-image
debug-context-base
@@ -52,9 +52,11 @@
arity-high-pc
arity-nreq
arity-nopt
+ arity-nlocals
arity-has-rest?
arity-allow-other-keys?
arity-has-keyword-args?
+ arity-keyword-args
arity-is-case-lambda?
debug-context-from-image
@@ -64,6 +66,7 @@
find-program-debug-info
arity-arguments-alist
find-program-arities
+ find-program-arity
find-program-minimum-arity
find-program-docstring
@@ -244,7 +247,7 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
(header-offset arity-header-offset))
(define arities-prefix-len 4)
-(define arity-header-len (* 6 4))
+(define arity-header-len (* 7 4))
;;; struct arity_header {
;;; uint32_t low_pc;
@@ -253,6 +256,7 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
;;; uint32_t flags;
;;; uint32_t nreq;
;;; uint32_t nopt;
+;;; uint32_t nlocals;
;;; }
(define (arity-low-pc* bv header-pos)
@@ -267,6 +271,8 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
(bytevector-u32-native-ref bv (+ header-pos (* 4 4))))
(define (arity-nopt* bv header-pos)
(bytevector-u32-native-ref bv (+ header-pos (* 5 4))))
+(define (arity-nlocals* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 6 4))))
;;; #x1: has-rest?
;;; #x2: allow-other-keys?
@@ -302,6 +308,10 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
(arity-nopt* (elf-bytes (debug-context-elf (arity-context arity)))
(arity-header-offset arity)))
+(define (arity-nlocals arity)
+ (arity-nlocals* (elf-bytes (debug-context-elf (arity-context arity)))
+ (arity-header-offset arity)))
+
(define (arity-flags arity)
(arity-flags* (elf-bytes (debug-context-elf (arity-context arity)))
(arity-header-offset arity)))
@@ -312,6 +322,18 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
(define (arity-is-case-lambda? arity) (is-case-lambda? (arity-flags arity)))
(define (arity-is-in-case-lambda? arity) (is-in-case-lambda? (arity-flags
arity)))
+(define (arity-keyword-args arity)
+ (define (unpack-scm n)
+ (pointer->scm (make-pointer n)))
+ (if (arity-has-keyword-args? arity)
+ (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+ (header (arity-header-offset arity))
+ (link-offset (arity-offset* bv header))
+ (link (+ (arity-base arity) link-offset))
+ (offset (bytevector-u32-native-ref bv link)))
+ (unpack-scm (+ (debug-context-base (arity-context arity)) offset)))
+ '()))
+
(define (arity-load-symbol arity)
(let ((elf (debug-context-elf (arity-context arity))))
(cond
@@ -325,37 +347,70 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
(string->symbol (string-table-ref bv (+ strtab-offset n)))))))
(else (error "couldn't find arities section")))))
-(define (arity-arguments-alist arity)
+(define* (arity-locals arity #:optional nlocals)
(let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
- (%load-symbol (arity-load-symbol arity))
+ (load-symbol (arity-load-symbol arity))
(header (arity-header-offset arity))
+ (nlocals (if nlocals
+ (if (<= 0 nlocals (arity-nlocals* bv header))
+ nlocals
+ (error "request for too many locals"))
+ (arity-nlocals* bv header)))
+ (flags (arity-flags* bv header))
(link-offset (arity-offset* bv header))
- (link (+ (arity-base arity) link-offset))
+ (link (+ (arity-base arity)
+ link-offset
+ (if (has-keyword-args? flags) 4 0))))
+ (define (read-uleb128 bv pos)
+ ;; Unrolled by one.
+ (let ((b (bytevector-u8-ref bv pos)))
+ (if (zero? (logand b #x80))
+ (values b
+ (1+ pos))
+ (let lp ((n (logxor #x80 b)) (pos (1+ pos)) (shift 7))
+ (let ((b (bytevector-u8-ref bv pos)))
+ (if (zero? (logand b #x80))
+ (values (logior (ash b shift) n)
+ (1+ pos))
+ (lp (logior (ash (logxor #x80 b) shift) n)
+ (1+ pos)
+ (+ shift 7))))))))
+ (define (load-symbols pos n)
+ (let lp ((pos pos) (n n) (out '()))
+ (if (zero? n)
+ (reverse out)
+ (call-with-values (lambda () (read-uleb128 bv pos))
+ (lambda (strtab-offset pos)
+ strtab-offset
+ (lp pos
+ (1- n)
+ (cons (if (zero? strtab-offset)
+ #f
+ (load-symbol strtab-offset))
+ out)))))))
+ (when (is-case-lambda? flags)
+ (error "invalid request for locals of case-lambda wrapper arity"))
+ (load-symbols link nlocals)))
+
+(define (arity-arguments-alist arity)
+ (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+ (header (arity-header-offset arity))
(flags (arity-flags* bv header))
(nreq (arity-nreq* bv header))
- (nopt (arity-nopt* bv header)))
- (define (load-symbol idx)
- (%load-symbol (bytevector-u32-native-ref bv (+ link (* idx 4)))))
- (define (load-symbols skip n)
- (let lp ((n n) (out '()))
- (if (zero? n)
- out
- (lp (1- n)
- (cons (load-symbol (+ skip (1- n))) out)))))
- (define (unpack-scm n)
- (pointer->scm (make-pointer n)))
- (define (load-non-immediate idx)
- (let ((offset (bytevector-u32-native-ref bv (+ link (* idx 4)))))
- (unpack-scm (+ (debug-context-base (arity-context arity)) offset))))
- (and (not (is-case-lambda? flags))
- `((required . ,(load-symbols 0 nreq))
- (optional . ,(load-symbols nreq nopt))
- (keyword . ,(if (has-keyword-args? flags)
- (load-non-immediate
- (+ nreq nopt (if (has-rest? flags) 1 0)))
- '()))
- (allow-other-keys? . ,(allow-other-keys? flags))
- (rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt))))))))
+ (nopt (arity-nopt* bv header))
+ (nargs (+ nreq nopt (if (has-rest? flags) 1 0))))
+ (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)))))))))))
(define (find-first-arity context base addr)
(let* ((bv (elf-bytes (debug-context-elf context)))
@@ -405,6 +460,17 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
(read-sub-arities context base (arity-header-offset first)))
(else (list first)))))))
+(define* (find-program-arity addr #:optional
+ (context (find-debug-context addr)))
+ (let lp ((arities (or (find-program-arities addr context) '())))
+ (match arities
+ (() #f)
+ ((arity . arities)
+ (if (and (<= (arity-low-pc arity) addr)
+ (< addr (arity-high-pc arity)))
+ arity
+ (lp arities))))))
+
(define* (find-program-minimum-arity addr #:optional
(context (find-debug-context addr)))
(and=>
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index a5de861..a573079 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -1,6 +1,6 @@
;;; Guile VM frame functions
-;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012, 2013 Free Software
Foundation, Inc.
+;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012, 2013, 2014 Free Software
Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -21,6 +21,7 @@
(define-module (system vm frame)
#:use-module (system base pmatch)
#:use-module (system vm program)
+ #:use-module (system vm debug)
#:export (frame-bindings
frame-lookup-binding
frame-binding-ref frame-binding-set!
@@ -83,49 +84,53 @@
;; stack, and nothing else is on the stack.
(define (frame-call-representation frame)
- (let ((p (frame-procedure frame)))
+ (let* ((ip (frame-instruction-pointer frame))
+ (info (find-program-debug-info ip))
+ (nlocals (frame-num-locals frame))
+ (closure (frame-procedure frame)))
+ (define (local-ref i)
+ (if (< i nlocals)
+ (frame-local-ref frame i)
+ ;; Let's not error here, as we are called during backtraces.
+ '???))
(cons
- (or (false-if-exception (procedure-name p)) p)
+ (or (and=> info program-debug-info-name)
+ (procedure-name closure)
+ (and info
+ ;; No need to give source info, as backtraces will already
+ ;; take care of that.
+ (format #f "#<procedure ~a>"
+ (number->string (program-debug-info-addr info) 16)))
+ (procedure-name closure)
+ closure)
(cond
- ((and (program? p)
- (program-arguments-alist p (frame-instruction-pointer frame)))
- ;; case 1
- => (lambda (arguments)
- (define (binding-ref sym i)
- (cond
- ((frame-lookup-binding frame sym)
- => (lambda (b) (frame-local-ref frame (binding:index b))))
- ((< i (frame-num-locals frame))
- (frame-local-ref frame i))
- (else
- ;; let's not error here, as we are called during backtraces...
- '???)))
- (let lp ((req (or (assq-ref arguments 'required) '()))
- (opt (or (assq-ref arguments 'optional) '()))
- (key (or (assq-ref arguments 'keyword) '()))
- (rest (or (assq-ref arguments 'rest) #f))
+ ((find-program-arity ip)
+ => (lambda (arity)
+ ;; case 1
+ (let lp ((nreq (arity-nreq arity))
+ (nopt (arity-nopt arity))
+ (kw (arity-keyword-args arity))
+ (has-rest? (arity-has-rest? arity))
(i 1))
(cond
- ((pair? req)
- (cons (binding-ref (car req) i)
- (lp (cdr req) opt key rest (1+ i))))
- ((pair? opt)
- (cons (binding-ref (car opt) i)
- (lp req (cdr opt) key rest (1+ i))))
- ((pair? key)
- (cons* (caar key)
- (frame-local-ref frame (cdar key))
- (lp req opt (cdr key) rest (1+ i))))
- (rest
- (binding-ref rest i))
+ ((positive? nreq)
+ (cons (local-ref i)
+ (lp (1- nreq) nopt kw has-rest? (1+ i))))
+ ((positive? nopt)
+ (cons (local-ref i)
+ (lp nreq (1- nopt) kw has-rest? (1+ i))))
+ ((pair? kw)
+ (cons* (caar kw) (local-ref (cdar kw))
+ (lp nreq nopt (cdr kw) has-rest? (1+ i))))
+ (has-rest?
+ (local-ref i))
(else
'())))))
(else
;; case 2
- (map (lambda (i)
- (frame-local-ref frame i))
+ (map local-ref
;; Cdr past the 0th local, which is the procedure.
- (cdr (iota (frame-num-locals frame)))))))))
+ (cdr (iota nlocals))))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-932-g67ddb7e,
Andy Wingo <=