mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 06:50:31 +02:00
Code Activity

Tweak arities debugging representation

Browse source 
* 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 :/
This commit is contained in:
Andy Wingo 2014-04-15 15:27:19 +02:00
parent 78351d1065
commit cade4c8fe1
2 changed files with 45 additions and 51 deletions
Download patch file Download diff file Expand all files Collapse all files

51
module/system/vm/assembler.scm
View file

@ -1419,12 +1419,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
;;; links for required arguments are first, in order, as uint32 values.
;;; Next follow the optionals, then the rest link if has-rest? 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.
;;;
;;; Functions with no arities have no arities information present in the
;;; .guile.arities section.
@ -1459,10 +1462,10 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(define (lambda-size arity)
(+ arity-header-len
(* 4 ;; name pointers
(+ (length (arity-req arity))
(+ (if (pair? (arity-kw-indices arity)) 1 0)
(length (arity-req arity))
(length (arity-opt arity))
(if (arity-rest arity) 1 0)
(if (pair? (arity-kw-indices arity)) 1 0)))))
(if (arity-rest arity) 1 0)))))
(define (case-lambda-size arities)
(fold +
arity-header-len ;; case-lambda header
@ -1540,19 +1543,23 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
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)))))))))
(call-with-values
(lambda ()
(match (arity-kw-indices arity)
(() (values pos relocs))
(kw-indices
(values (+ pos 4)
(cons (write-kw-indices pos kw-indices) relocs)))))
(lambda (pos relocs)
(lp (fold write-symbol
pos
(append (arity-req arity)
(arity-opt arity)
(cond
((arity-rest arity) => list)
(else '()))))
pairs
relocs)))))))
(define (link-arities asm)
(let* ((endianness (asm-endianness asm))

45
module/system/vm/debug.scm
View file

@ -328,33 +328,28 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
(else (error "couldn't find arities section")))))
(define (arity-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))
(flags (arity-flags* bv header))
(nreq (arity-nreq* bv header))
(nopt (arity-nopt* bv header)))
(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))))
(if (and (not (is-case-lambda? flags))
(has-keyword-args? flags))
(load-non-immediate
(+ nreq nopt (if (has-rest? flags) 1 0)))
'())))
(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-arguments-alist arity)
(let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
(%load-symbol (arity-load-symbol arity))
(header (arity-header-offset arity))
(link-offset (arity-offset* bv header))
(link (+ (arity-base arity) link-offset))
(flags (arity-flags* bv header))
(nreq (arity-nreq* bv header))
(nopt (arity-nopt* bv header)))
(nopt (arity-nopt* bv header))
(link-offset (arity-offset* bv header))
(link (+ (arity-base arity)
link-offset
(if (has-keyword-args? flags) 4 0))))
(define (load-symbol idx)
(%load-symbol (bytevector-u32-native-ref bv (+ link (* idx 4)))))
(define (load-symbols skip n)
@ -363,18 +358,10 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
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)))
'()))
(keyword . ,(arity-keyword-args arity))
(allow-other-keys? . ,(allow-other-keys? flags))
(rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt))))))))