* [PATCH 1/9] begin-program takes properties alist
2013-06-04 14:44 Serialize procedure metadata into ELF for RTL programs Andy Wingo
@ 2013-06-04 14:44 ` Andy Wingo
2013-06-04 14:44 ` [PATCH 2/9] add procedure prelude macro-instructions Andy Wingo
` (7 subsequent siblings)
8 siblings, 0 replies; 11+ messages in thread
From: Andy Wingo @ 2013-06-04 14:44 UTC (permalink / raw)
To: guile-devel; +Cc: Andy Wingo
* module/system/vm/assembler.scm (check): New helper macro to check
argument types.
(<meta>): Add properties field. Rename name field to "label" to
indicate that it should be unique.
(make-meta, meta-name): New helpers.
(begin-program): Take additional properties argument.
(emit-init-constants): Adapt to begin-program change.
(link-symtab): Allow for anonymous procedures.
* test-suite/tests/rtl.test: Adapt tests.
---
module/system/vm/assembler.scm | 31 ++++++++++++++++-----
test-suite/tests/rtl.test | 58 ++++++++++++++++++++++++++--------------
2 files changed, 62 insertions(+), 27 deletions(-)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 7eb6049..b355b85 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -26,6 +26,7 @@
#:use-module (system vm objcode)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 vlist)
+ #:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-4)
#:use-module (srfi srfi-9)
@@ -59,13 +60,27 @@
(define-syntax-rule (pack-u8-u8-u8-u8 x y z w)
(logior x (ash y 8) (ash z 16) (ash w 24)))
+(define-syntax-rule (check arg pattern kind)
+ (let ((x arg))
+ (unless (match x (pattern #t) (_ #f))
+ (error (string-append "expected " kind) x))))
+
(define-record-type <meta>
- (make-meta name low-pc high-pc)
+ (%make-meta label properties low-pc high-pc)
meta?
- (name meta-name)
+ (label meta-label)
+ (properties meta-properties set-meta-properties!)
(low-pc meta-low-pc)
(high-pc meta-high-pc set-meta-high-pc!))
+(define (make-meta label properties low-pc)
+ (check label (? symbol?) "symbol")
+ (check properties (((? symbol?) . _) ...) "alist with symbolic keys")
+ (%make-meta label properties low-pc #f))
+
+(define (meta-name meta)
+ (assq-ref (meta-properties meta) 'name))
+
(define-syntax *block-size* (identifier-syntax 32))
;; We'll use native endianness when writing bytecode. If we're
@@ -435,13 +450,14 @@
(let ((loc (intern-constant asm (make-static-procedure label))))
(emit-make-non-immediate asm dst loc)))
-(define-macro-assembler (begin-program asm label)
+(define-macro-assembler (begin-program asm label properties)
(emit-label asm label)
- (let ((meta (make-meta label (asm-start asm) #f)))
+ (let ((meta (make-meta label properties (asm-start asm))))
(set-asm-meta! asm (cons meta (asm-meta asm)))))
(define-macro-assembler (end-program asm)
- (set-meta-high-pc! (car (asm-meta asm)) (asm-start asm)))
+ (let ((meta (car (asm-meta asm))))
+ (set-meta-high-pc! meta (asm-start asm))))
(define-macro-assembler (label asm sym)
(set-asm-labels! asm (acons sym (asm-start asm) (asm-labels asm))))
@@ -623,7 +639,7 @@
(and (not (null? inits))
(let ((label (gensym "init-constants")))
(emit-text asm
- `((begin-program ,label)
+ `((begin-program ,label ())
(assert-nargs-ee/locals 0 1)
,@(reverse inits)
(load-constant 0 ,*unspecified*)
@@ -821,7 +837,8 @@
(bv (make-bytevector (* n size) 0)))
(define (intern-string! name)
(call-with-values
- (lambda () (string-table-intern strtab (symbol->string name)))
+ (lambda () (string-table-intern strtab
+ (if name (symbol->string name) "")))
(lambda (table idx)
(set! strtab table)
idx)))
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 8429512..2f5918f 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -27,7 +27,8 @@
(pass-if (object->string x) (equal? expr x))))
(define (return-constant val)
- (assemble-program `((begin-program foo)
+ (assemble-program `((begin-program foo
+ ((name . foo)))
(assert-nargs-ee/locals 0 1)
(load-constant 0 ,val)
(return 0)
@@ -63,12 +64,14 @@
(with-test-prefix "static procedure"
(assert-equal 42
- (((assemble-program `((begin-program foo)
+ (((assemble-program `((begin-program foo
+ ((name . foo)))
(assert-nargs-ee/locals 0 1)
(load-static-procedure 0 bar)
(return 0)
(end-program)
- (begin-program bar)
+ (begin-program bar
+ ((name . bar)))
(assert-nargs-ee/locals 0 1)
(load-constant 0 42)
(return 0)
@@ -81,7 +84,8 @@
;; 0: limit
;; 1: n
;; 2: accum
- '((begin-program countdown)
+ '((begin-program countdown
+ ((name . countdown)))
(assert-nargs-ee/locals 1 2)
(br fix-body)
(label loop-head)
@@ -105,14 +109,16 @@
;; 0: elt
;; 1: tail
;; 2: head
- '((begin-program make-accum)
+ '((begin-program make-accum
+ ((name . make-accum)))
(assert-nargs-ee/locals 0 2)
(load-constant 0 0)
(box 0 0)
(make-closure 1 accum (0))
(return 1)
(end-program)
- (begin-program accum)
+ (begin-program accum
+ ((name . accum)))
(assert-nargs-ee/locals 1 2)
(free-ref 1 0)
(box-ref 2 1)
@@ -129,7 +135,8 @@
(assert-equal 42
(let ((call ;; (lambda (x) (x))
(assemble-program
- '((begin-program call)
+ '((begin-program call
+ ((name . call)))
(assert-nargs-ee/locals 1 0)
(call 1 0 ())
(return 1) ;; MVRA from call
@@ -140,7 +147,8 @@
(assert-equal 6
(let ((call-with-3 ;; (lambda (x) (x 3))
(assemble-program
- '((begin-program call-with-3)
+ '((begin-program call-with-3
+ ((name . call-with-3)))
(assert-nargs-ee/locals 1 1)
(load-constant 1 3)
(call 2 0 (1))
@@ -153,7 +161,8 @@
(assert-equal 3
(let ((call ;; (lambda (x) (x))
(assemble-program
- '((begin-program call)
+ '((begin-program call
+ ((name . call)))
(assert-nargs-ee/locals 1 0)
(tail-call 0 0)
(end-program)))))
@@ -162,7 +171,8 @@
(assert-equal 6
(let ((call-with-3 ;; (lambda (x) (x 3))
(assemble-program
- '((begin-program call-with-3)
+ '((begin-program call-with-3
+ ((name . call-with-3)))
(assert-nargs-ee/locals 1 1)
(mov 1 0) ;; R1 <- R0
(load-constant 0 3) ;; R0 <- 3
@@ -174,14 +184,16 @@
(assert-equal 5.0
(let ((get-sqrt-trampoline
(assemble-program
- '((begin-program get-sqrt-trampoline)
+ '((begin-program get-sqrt-trampoline
+ ((name . get-sqrt-trampoline)))
(assert-nargs-ee/locals 0 1)
(cache-current-module! 0 sqrt-scope)
(load-static-procedure 0 sqrt-trampoline)
(return 0)
(end-program)
- (begin-program sqrt-trampoline)
+ (begin-program sqrt-trampoline
+ ((name . sqrt-trampoline)))
(assert-nargs-ee/locals 1 1)
(cached-toplevel-ref 1 sqrt-scope sqrt)
(tail-call 1 1)
@@ -195,14 +207,16 @@
(assert-equal (1+ prev)
(let ((make-top-incrementor
(assemble-program
- '((begin-program make-top-incrementor)
+ '((begin-program make-top-incrementor
+ ((name . make-top-incrementor)))
(assert-nargs-ee/locals 0 1)
(cache-current-module! 0 top-incrementor)
(load-static-procedure 0 top-incrementor)
(return 0)
(end-program)
- (begin-program top-incrementor)
+ (begin-program top-incrementor
+ ((name . top-incrementor)))
(assert-nargs-ee/locals 0 1)
(cached-toplevel-ref 0 top-incrementor *top-val*)
(add1 0 0)
@@ -216,13 +230,15 @@
(assert-equal 5.0
(let ((get-sqrt-trampoline
(assemble-program
- '((begin-program get-sqrt-trampoline)
+ '((begin-program get-sqrt-trampoline
+ ((name . get-sqrt-trampoline)))
(assert-nargs-ee/locals 0 1)
(load-static-procedure 0 sqrt-trampoline)
(return 0)
(end-program)
- (begin-program sqrt-trampoline)
+ (begin-program sqrt-trampoline
+ ((name . sqrt-trampoline)))
(assert-nargs-ee/locals 1 1)
(cached-module-ref 1 (guile) #t sqrt)
(tail-call 1 1)
@@ -234,13 +250,15 @@
(assert-equal (1+ prev)
(let ((make-top-incrementor
(assemble-program
- '((begin-program make-top-incrementor)
+ '((begin-program make-top-incrementor
+ ((name . make-top-incrementor)))
(assert-nargs-ee/locals 0 1)
(load-static-procedure 0 top-incrementor)
(return 0)
(end-program)
- (begin-program top-incrementor)
+ (begin-program top-incrementor
+ ((name . top-incrementor)))
(assert-nargs-ee/locals 0 1)
(cached-module-ref 0 (tests rtl) #f *top-val*)
(add1 0 0)
@@ -252,7 +270,7 @@
(with-test-prefix "debug contexts"
(let ((return-3 (assemble-program
- '((begin-program return-3)
+ '((begin-program return-3 ((name . return-3)))
(assert-nargs-ee/locals 0 1)
(load-constant 0 3)
(return 0)
@@ -273,7 +291,7 @@
(pass-if-equal 'foo
(procedure-name
(assemble-program
- '((begin-program foo)
+ '((begin-program foo ((name . foo)))
(assert-nargs-ee/locals 0 1)
(load-constant 0 42)
(return 0)
--
1.7.10.4
^ permalink raw reply related [flat|nested] 11+ messages in thread* [PATCH 2/9] add procedure prelude macro-instructions
2013-06-04 14:44 Serialize procedure metadata into ELF for RTL programs Andy Wingo
2013-06-04 14:44 ` [PATCH 1/9] begin-program takes properties alist Andy Wingo
@ 2013-06-04 14:44 ` Andy Wingo
2013-06-04 14:44 ` [PATCH 3/9] Beginnings of tracking of procedure arities in assembler Andy Wingo
` (6 subsequent siblings)
8 siblings, 0 replies; 11+ messages in thread
From: Andy Wingo @ 2013-06-04 14:44 UTC (permalink / raw)
To: guile-devel; +Cc: Andy Wingo
* module/system/vm/assembler.scm (pack-flags): New helper.
(standard-prelude, opt-prelude, kw-prelude): New macro-instructions.
* test-suite/tests/rtl.test: Update tests to use standard-prelude.
---
module/system/vm/assembler.scm | 48 ++++++++++++++++++++++++++++++++++++++++
test-suite/tests/rtl.test | 40 ++++++++++++++++-----------------
2 files changed, 68 insertions(+), 20 deletions(-)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index b355b85..9538d71 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -36,6 +36,12 @@
link-assembly
assemble-program))
+(define-syntax pack-flags
+ (syntax-rules ()
+ ;; Add clauses as needed.
+ ((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0)
+ (if f2 (ash 2 0) 0)))))
+
(define-syntax-rule (pack-u8-u24 x y)
(logior x (ash y 8)))
@@ -459,6 +465,48 @@
(let ((meta (car (asm-meta asm))))
(set-meta-high-pc! meta (asm-start asm))))
+(define-macro-assembler (standard-prelude asm nreq nlocals alternate)
+ (cond
+ (alternate
+ (emit-br-if-nargs-ne asm nreq alternate)
+ (emit-reserve-locals asm nlocals))
+ ((and (< nreq (ash 1 12)) (< (- nlocals nreq) (ash 1 12)))
+ (emit-assert-nargs-ee/locals asm nreq (- nlocals nreq)))
+ (else
+ (emit-assert-nargs-ee asm nreq)
+ (emit-reserve-locals asm nlocals))))
+
+(define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate)
+ (if alternate
+ (emit-br-if-nargs-lt asm nreq alternate)
+ (emit-assert-nargs-ge asm nreq))
+ (cond
+ (rest?
+ (emit-bind-rest asm (+ nreq nopt)))
+ (alternate
+ (emit-br-if-nargs-gt asm (+ nreq nopt) alternate))
+ (else
+ (emit-assert-nargs-le asm (+ nreq nopt))))
+ (emit-reserve-locals asm nlocals))
+
+(define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices
+ allow-other-keys? nlocals alternate)
+ (if alternate
+ (emit-br-if-nargs-lt asm nreq alternate)
+ (emit-assert-nargs-ge asm nreq))
+ (let ((ntotal (fold (lambda (kw ntotal)
+ (match kw
+ (((? keyword?) . idx)
+ (max (1+ idx) ntotal))))
+ (+ nreq nopt) kw-indices)))
+ ;; FIXME: port 581f410f
+ (emit-bind-kwargs asm nreq
+ (pack-flags allow-other-keys? rest?)
+ (+ nreq nopt)
+ ntotal
+ kw-indices)
+ (emit-reserve-locals asm nlocals)))
+
(define-macro-assembler (label asm sym)
(set-asm-labels! asm (acons sym (asm-start asm) (asm-labels asm))))
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 2f5918f..02e6993 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -29,7 +29,7 @@
(define (return-constant val)
(assemble-program `((begin-program foo
((name . foo)))
- (assert-nargs-ee/locals 0 1)
+ (standard-prelude 0 1 #f)
(load-constant 0 ,val)
(return 0)
(end-program))))
@@ -66,13 +66,13 @@
(assert-equal 42
(((assemble-program `((begin-program foo
((name . foo)))
- (assert-nargs-ee/locals 0 1)
+ (standard-prelude 0 1 #f)
(load-static-procedure 0 bar)
(return 0)
(end-program)
(begin-program bar
((name . bar)))
- (assert-nargs-ee/locals 0 1)
+ (standard-prelude 0 1 #f)
(load-constant 0 42)
(return 0)
(end-program)))))))
@@ -86,7 +86,7 @@
;; 2: accum
'((begin-program countdown
((name . countdown)))
- (assert-nargs-ee/locals 1 2)
+ (standard-prelude 1 3 #f)
(br fix-body)
(label loop-head)
(br-if-= 1 0 out)
@@ -111,7 +111,7 @@
;; 2: head
'((begin-program make-accum
((name . make-accum)))
- (assert-nargs-ee/locals 0 2)
+ (standard-prelude 0 2 #f)
(load-constant 0 0)
(box 0 0)
(make-closure 1 accum (0))
@@ -119,7 +119,7 @@
(end-program)
(begin-program accum
((name . accum)))
- (assert-nargs-ee/locals 1 2)
+ (standard-prelude 1 3 #f)
(free-ref 1 0)
(box-ref 2 1)
(add 2 2 0)
@@ -137,7 +137,7 @@
(assemble-program
'((begin-program call
((name . call)))
- (assert-nargs-ee/locals 1 0)
+ (standard-prelude 1 1 #f)
(call 1 0 ())
(return 1) ;; MVRA from call
(return 1) ;; RA from call
@@ -149,7 +149,7 @@
(assemble-program
'((begin-program call-with-3
((name . call-with-3)))
- (assert-nargs-ee/locals 1 1)
+ (standard-prelude 1 2 #f)
(load-constant 1 3)
(call 2 0 (1))
(return 2) ;; MVRA from call
@@ -163,7 +163,7 @@
(assemble-program
'((begin-program call
((name . call)))
- (assert-nargs-ee/locals 1 0)
+ (standard-prelude 1 1 #f)
(tail-call 0 0)
(end-program)))))
(call (lambda () 3))))
@@ -173,7 +173,7 @@
(assemble-program
'((begin-program call-with-3
((name . call-with-3)))
- (assert-nargs-ee/locals 1 1)
+ (standard-prelude 1 2 #f)
(mov 1 0) ;; R1 <- R0
(load-constant 0 3) ;; R0 <- 3
(tail-call 1 1)
@@ -186,7 +186,7 @@
(assemble-program
'((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline)))
- (assert-nargs-ee/locals 0 1)
+ (standard-prelude 0 1 #f)
(cache-current-module! 0 sqrt-scope)
(load-static-procedure 0 sqrt-trampoline)
(return 0)
@@ -194,7 +194,7 @@
(begin-program sqrt-trampoline
((name . sqrt-trampoline)))
- (assert-nargs-ee/locals 1 1)
+ (standard-prelude 1 2 #f)
(cached-toplevel-ref 1 sqrt-scope sqrt)
(tail-call 1 1)
(end-program)))))
@@ -209,7 +209,7 @@
(assemble-program
'((begin-program make-top-incrementor
((name . make-top-incrementor)))
- (assert-nargs-ee/locals 0 1)
+ (standard-prelude 0 1 #f)
(cache-current-module! 0 top-incrementor)
(load-static-procedure 0 top-incrementor)
(return 0)
@@ -217,7 +217,7 @@
(begin-program top-incrementor
((name . top-incrementor)))
- (assert-nargs-ee/locals 0 1)
+ (standard-prelude 0 1 #f)
(cached-toplevel-ref 0 top-incrementor *top-val*)
(add1 0 0)
(cached-toplevel-set! 0 top-incrementor *top-val*)
@@ -232,14 +232,14 @@
(assemble-program
'((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline)))
- (assert-nargs-ee/locals 0 1)
+ (standard-prelude 0 1 #f)
(load-static-procedure 0 sqrt-trampoline)
(return 0)
(end-program)
(begin-program sqrt-trampoline
((name . sqrt-trampoline)))
- (assert-nargs-ee/locals 1 1)
+ (standard-prelude 1 2 #f)
(cached-module-ref 1 (guile) #t sqrt)
(tail-call 1 1)
(end-program)))))
@@ -252,14 +252,14 @@
(assemble-program
'((begin-program make-top-incrementor
((name . make-top-incrementor)))
- (assert-nargs-ee/locals 0 1)
+ (standard-prelude 0 1 #f)
(load-static-procedure 0 top-incrementor)
(return 0)
(end-program)
(begin-program top-incrementor
((name . top-incrementor)))
- (assert-nargs-ee/locals 0 1)
+ (standard-prelude 0 1 #f)
(cached-module-ref 0 (tests rtl) #f *top-val*)
(add1 0 0)
(cached-module-set! 0 (tests rtl) #f *top-val*)
@@ -271,7 +271,7 @@
(with-test-prefix "debug contexts"
(let ((return-3 (assemble-program
'((begin-program return-3 ((name . return-3)))
- (assert-nargs-ee/locals 0 1)
+ (standard-prelude 0 1 #f)
(load-constant 0 3)
(return 0)
(end-program)))))
@@ -292,7 +292,7 @@
(procedure-name
(assemble-program
'((begin-program foo ((name . foo)))
- (assert-nargs-ee/locals 0 1)
+ (standard-prelude 0 1 #f)
(load-constant 0 42)
(return 0)
(end-program))))))
--
1.7.10.4
^ permalink raw reply related [flat|nested] 11+ messages in thread* [PATCH 3/9] Beginnings of tracking of procedure arities in assembler
2013-06-04 14:44 Serialize procedure metadata into ELF for RTL programs Andy Wingo
2013-06-04 14:44 ` [PATCH 1/9] begin-program takes properties alist Andy Wingo
2013-06-04 14:44 ` [PATCH 2/9] add procedure prelude macro-instructions Andy Wingo
@ 2013-06-04 14:44 ` Andy Wingo
2013-06-04 14:44 ` [PATCH 4/9] RTL assembler writes arities information into separate section Andy Wingo
` (5 subsequent siblings)
8 siblings, 0 replies; 11+ messages in thread
From: Andy Wingo @ 2013-06-04 14:44 UTC (permalink / raw)
To: guile-devel; +Cc: Andy Wingo
* module/system/vm/assembler.scm (<meta>, <arity>): Assembler now tracks
arities of a function.
(begin-standard-arity, begin-opt-arity, begin-kw-arity, end-arity):
New macro-assemblers.
* test-suite/tests/rtl.test: Adapt all tests to use begin-standard-arity
and end-arity.
---
module/system/vm/assembler.scm | 59 ++++++++++++++++++++++++++++++++++++---
test-suite/tests/rtl.test | 60 ++++++++++++++++++++++++++--------------
2 files changed, 95 insertions(+), 24 deletions(-)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 9538d71..47f31ed 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -72,21 +72,35 @@
(error (string-append "expected " kind) x))))
(define-record-type <meta>
- (%make-meta label properties low-pc high-pc)
+ (%make-meta label properties low-pc high-pc arities)
meta?
(label meta-label)
(properties meta-properties set-meta-properties!)
(low-pc meta-low-pc)
- (high-pc meta-high-pc set-meta-high-pc!))
+ (high-pc meta-high-pc set-meta-high-pc!)
+ (arities meta-arities set-meta-arities!))
(define (make-meta label properties low-pc)
(check label (? symbol?) "symbol")
(check properties (((? symbol?) . _) ...) "alist with symbolic keys")
- (%make-meta label properties low-pc #f))
+ (%make-meta label properties low-pc #f '()))
(define (meta-name meta)
(assq-ref (meta-properties meta) 'name))
+;; Metadata for one <lambda-case>.
+(define-record-type <arity>
+ (make-arity req opt rest kw-indices allow-other-keys?
+ low-pc high-pc)
+ arity?
+ (req arity-req)
+ (opt arity-opt)
+ (rest arity-rest)
+ (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!))
+
(define-syntax *block-size* (identifier-syntax 32))
;; We'll use native endianness when writing bytecode. If we're
@@ -463,7 +477,44 @@
(define-macro-assembler (end-program asm)
(let ((meta (car (asm-meta asm))))
- (set-meta-high-pc! meta (asm-start asm))))
+ (set-meta-high-pc! meta (asm-start asm))
+ (set-meta-arities! meta (reverse (meta-arities meta)))))
+
+(define-macro-assembler (begin-standard-arity asm req nlocals alternate)
+ (emit-begin-opt-arity asm req '() #f nlocals alternate))
+
+(define-macro-assembler (begin-opt-arity asm req opt rest nlocals alternate)
+ (emit-begin-kw-arity asm req opt rest '() #f nlocals alternate))
+
+(define-macro-assembler (begin-kw-arity asm req opt rest kw-indices
+ allow-other-keys? nlocals alternate)
+ (check req ((? symbol?) ...) "list of symbols")
+ (check opt ((? symbol?) ...) "list of symbols")
+ (check rest (or #f (? symbol?)) "#f or symbol")
+ (check kw-indices (((? symbol?) . (? integer?)) ...)
+ "alist of symbol -> integer")
+ (check allow-other-keys? (? boolean?) "boolean")
+ (check nlocals (? integer?) "integer")
+ (check alternate (or #f (? 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))
+ (nreq (length req))
+ (nopt (length opt))
+ (rest? (->bool rest)))
+ (set-meta-arities! meta (cons arity (meta-arities meta)))
+ (cond
+ ((or allow-other-keys? (pair? kw-indices))
+ (emit-kw-prelude asm nreq nopt rest? kw-indices allow-other-keys?
+ nlocals alternate))
+ ((or rest? (pair? opt))
+ (emit-opt-prelude asm nreq nopt rest? nlocals alternate))
+ (else
+ (emit-standard-prelude asm nreq nlocals alternate)))))
+
+(define-macro-assembler (end-arity asm)
+ (let ((arity (car (meta-arities (car (asm-meta asm))))))
+ (set-arity-high-pc! arity (asm-start asm))))
(define-macro-assembler (standard-prelude asm nreq nlocals alternate)
(cond
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 02e6993..1813969 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -29,9 +29,10 @@
(define (return-constant val)
(assemble-program `((begin-program foo
((name . foo)))
- (standard-prelude 0 1 #f)
+ (begin-standard-arity () 1 #f)
(load-constant 0 ,val)
(return 0)
+ (end-arity)
(end-program))))
(define-syntax-rule (assert-constants val ...)
@@ -66,15 +67,17 @@
(assert-equal 42
(((assemble-program `((begin-program foo
((name . foo)))
- (standard-prelude 0 1 #f)
+ (begin-standard-arity () 1 #f)
(load-static-procedure 0 bar)
(return 0)
+ (end-arity)
(end-program)
(begin-program bar
((name . bar)))
- (standard-prelude 0 1 #f)
+ (begin-standard-arity () 1 #f)
(load-constant 0 42)
(return 0)
+ (end-arity)
(end-program)))))))
(with-test-prefix "loop"
@@ -86,7 +89,7 @@
;; 2: accum
'((begin-program countdown
((name . countdown)))
- (standard-prelude 1 3 #f)
+ (begin-standard-arity (x) 3 #f)
(br fix-body)
(label loop-head)
(br-if-= 1 0 out)
@@ -99,6 +102,7 @@
(br loop-head)
(label out)
(return 2)
+ (end-arity)
(end-program)))))
(sumto 1000))))
@@ -111,20 +115,22 @@
;; 2: head
'((begin-program make-accum
((name . make-accum)))
- (standard-prelude 0 2 #f)
+ (begin-standard-arity () 2 #f)
(load-constant 0 0)
(box 0 0)
(make-closure 1 accum (0))
(return 1)
+ (end-arity)
(end-program)
(begin-program accum
((name . accum)))
- (standard-prelude 1 3 #f)
+ (begin-standard-arity (x) 3 #f)
(free-ref 1 0)
(box-ref 2 1)
(add 2 2 0)
(box-set! 1 2)
(return 2)
+ (end-arity)
(end-program)))))
(let ((accum (make-accum)))
(accum 1)
@@ -137,10 +143,11 @@
(assemble-program
'((begin-program call
((name . call)))
- (standard-prelude 1 1 #f)
+ (begin-standard-arity (f) 1 #f)
(call 1 0 ())
(return 1) ;; MVRA from call
(return 1) ;; RA from call
+ (end-arity)
(end-program)))))
(call (lambda () 42))))
@@ -149,11 +156,12 @@
(assemble-program
'((begin-program call-with-3
((name . call-with-3)))
- (standard-prelude 1 2 #f)
+ (begin-standard-arity (f) 2 #f)
(load-constant 1 3)
(call 2 0 (1))
(return 2) ;; MVRA from call
(return 2) ;; RA from call
+ (end-arity)
(end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
@@ -163,8 +171,9 @@
(assemble-program
'((begin-program call
((name . call)))
- (standard-prelude 1 1 #f)
+ (begin-standard-arity (f) 1 #f)
(tail-call 0 0)
+ (end-arity)
(end-program)))))
(call (lambda () 3))))
@@ -173,10 +182,11 @@
(assemble-program
'((begin-program call-with-3
((name . call-with-3)))
- (standard-prelude 1 2 #f)
+ (begin-standard-arity (f) 2 #f)
(mov 1 0) ;; R1 <- R0
(load-constant 0 3) ;; R0 <- 3
(tail-call 1 1)
+ (end-arity)
(end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
@@ -186,17 +196,19 @@
(assemble-program
'((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline)))
- (standard-prelude 0 1 #f)
+ (begin-standard-arity () 1 #f)
(cache-current-module! 0 sqrt-scope)
(load-static-procedure 0 sqrt-trampoline)
(return 0)
+ (end-arity)
(end-program)
(begin-program sqrt-trampoline
((name . sqrt-trampoline)))
- (standard-prelude 1 2 #f)
+ (begin-standard-arity (x) 2 #f)
(cached-toplevel-ref 1 sqrt-scope sqrt)
(tail-call 1 1)
+ (end-arity)
(end-program)))))
((get-sqrt-trampoline) 25.0))))
@@ -209,19 +221,21 @@
(assemble-program
'((begin-program make-top-incrementor
((name . make-top-incrementor)))
- (standard-prelude 0 1 #f)
+ (begin-standard-arity () 1 #f)
(cache-current-module! 0 top-incrementor)
(load-static-procedure 0 top-incrementor)
(return 0)
+ (end-arity)
(end-program)
(begin-program top-incrementor
((name . top-incrementor)))
- (standard-prelude 0 1 #f)
+ (begin-standard-arity () 1 #f)
(cached-toplevel-ref 0 top-incrementor *top-val*)
(add1 0 0)
(cached-toplevel-set! 0 top-incrementor *top-val*)
(return/values 0)
+ (end-arity)
(end-program)))))
((make-top-incrementor))
*top-val*))))
@@ -232,16 +246,18 @@
(assemble-program
'((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline)))
- (standard-prelude 0 1 #f)
+ (begin-standard-arity () 1 #f)
(load-static-procedure 0 sqrt-trampoline)
(return 0)
+ (end-arity)
(end-program)
(begin-program sqrt-trampoline
((name . sqrt-trampoline)))
- (standard-prelude 1 2 #f)
+ (begin-standard-arity (x) 2 #f)
(cached-module-ref 1 (guile) #t sqrt)
(tail-call 1 1)
+ (end-arity)
(end-program)))))
((get-sqrt-trampoline) 25.0))))
@@ -252,18 +268,20 @@
(assemble-program
'((begin-program make-top-incrementor
((name . make-top-incrementor)))
- (standard-prelude 0 1 #f)
+ (begin-standard-arity () 1 #f)
(load-static-procedure 0 top-incrementor)
(return 0)
+ (end-arity)
(end-program)
(begin-program top-incrementor
((name . top-incrementor)))
- (standard-prelude 0 1 #f)
+ (begin-standard-arity () 1 #f)
(cached-module-ref 0 (tests rtl) #f *top-val*)
(add1 0 0)
(cached-module-set! 0 (tests rtl) #f *top-val*)
(return 0)
+ (end-arity)
(end-program)))))
((make-top-incrementor))
*top-val*))))
@@ -271,9 +289,10 @@
(with-test-prefix "debug contexts"
(let ((return-3 (assemble-program
'((begin-program return-3 ((name . return-3)))
- (standard-prelude 0 1 #f)
+ (begin-standard-arity () 1 #f)
(load-constant 0 3)
(return 0)
+ (end-arity)
(end-program)))))
(pass-if "program name"
(and=> (find-program-debug-info (rtl-program-code return-3))
@@ -292,7 +311,8 @@
(procedure-name
(assemble-program
'((begin-program foo ((name . foo)))
- (standard-prelude 0 1 #f)
+ (begin-standard-arity () 1 #f)
(load-constant 0 42)
(return 0)
+ (end-arity)
(end-program))))))
--
1.7.10.4
^ permalink raw reply related [flat|nested] 11+ messages in thread* [PATCH 4/9] RTL assembler writes arities information into separate section.
2013-06-04 14:44 Serialize procedure metadata into ELF for RTL programs Andy Wingo
` (2 preceding siblings ...)
2013-06-04 14:44 ` [PATCH 3/9] Beginnings of tracking of procedure arities in assembler Andy Wingo
@ 2013-06-04 14:44 ` Andy Wingo
2013-06-04 14:44 ` [PATCH 5/9] (system vm debug) can read arity information Andy Wingo
` (4 subsequent siblings)
8 siblings, 0 replies; 11+ messages in thread
From: Andy Wingo @ 2013-06-04 14:44 UTC (permalink / raw)
To: guile-devel; +Cc: Andy Wingo
* module/system/vm/assembler.scm: Write arities into a .guile.arities
section and associated .guile.arities.strtab.
---
module/system/vm/assembler.scm | 201 +++++++++++++++++++++++++++++++++++++++-
1 file changed, 200 insertions(+), 1 deletion(-)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 47f31ed..342b3dc 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -968,6 +968,202 @@
(linker-object-section strtab)))
strtab))))
+;;; The .guile.arities section describes the arities that a function can
+;;; have. It is in two parts: a sorted array of headers describing
+;;; basic arities, and an array of links out to a string table (and in
+;;; the case of keyword arguments, to the data section) for argument
+;;; names. The whole thing is prefixed by a uint32 indicating the
+;;; offset of the end of the headers array.
+;;;
+;;; The arity headers array is a packed array of structures of the form:
+;;;
+;;; struct arity_header {
+;;; uint32_t low_pc;
+;;; uint32_t high_pc;
+;;; uint32_t offset;
+;;; uint32_t flags;
+;;; uint32_t nreq;
+;;; uint32_t nopt;
+;;; }
+;;;
+;;; All of the offsets and addresses are 32 bits. We can expand in the
+;;; future to use 64-bit offsets if appropriate, but there are other
+;;; aspects of RTL that constrain us to a total image that fits in 32
+;;; bits, so for the moment we'll simplify the problem space.
+;;;
+;;; The following flags values are defined:
+;;;
+;;; #x1: has-rest?
+;;; #x2: allow-other-keys?
+;;; #x4: has-keyword-args?
+;;; #x8: is-case-lambda?
+;;;
+;;; Functions with a single arity specify their number of required and
+;;; optional arguments in nreq and nopt, and do not have the
+;;; 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.
+;;;
+;;; Functions with no arities have no arities information present in the
+;;; .guile.arities section.
+;;;
+;;; Functions with multiple arities are preceded by a header with
+;;; is-case-lambda? set. All other fields are 0, except low-pc and
+;;; high-pc which should be the bounds of the whole function. Headers
+;;; for the individual arities follow. 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.
+
+;; Length of the prefix to the arities section, in bytes.
+(define arities-prefix-len 4)
+
+;; Length of an arity header, in bytes.
+(define arity-header-len (* 6 4))
+
+;; The offset of "offset" within arity header, in bytes.
+(define arity-header-offset-offset (* 2 4))
+
+(define-syntax-rule (pack-arity-flags has-rest? allow-other-keys?
+ has-keyword-args? is-case-lambda?)
+ (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)))
+
+(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 endianness)
+ (bytevector-u32-set! bv (+ pos 4) high-pc 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)
+ (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)
+ (length (arity-req arity))
+ (length (arity-opt arity))))
+ (let lp ((metas metas) (pos arities-prefix-len) (offsets '()))
+ (match metas
+ (() (values pos (reverse offsets)))
+ ((meta . metas)
+ (match (meta-arities meta)
+ (() (lp metas pos offsets))
+ ((arity)
+ (write-arity-header pos arity)
+ (lp metas
+ (+ pos arity-header-len)
+ (acons arity (+ pos arity-header-offset-offset) offsets)))
+ (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) 0 0)
+ (let lp* ((arities arities) (pos (+ pos arity-header-len))
+ (offsets offsets))
+ (match arities
+ (() (lp metas pos offsets))
+ ((arity . arities)
+ (write-arity-header pos arity)
+ (lp* arities
+ (+ pos arity-header-len)
+ (acons arity
+ (+ pos arity-header-offset-offset)
+ offsets)))))))))))
+
+(define (write-arity-links asm bv pos arity-offset-pairs intern-string!)
+ (define (write-symbol sym pos)
+ (bytevector-u32-set! bv pos (intern-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)))))))))
+
+(define (link-arities asm)
+ (let* ((endianness (asm-endianness asm))
+ (metas (reverse (asm-meta asm)))
+ (size (fold (lambda (meta size)
+ (+ size (meta-arities-size meta)))
+ arities-prefix-len
+ metas))
+ (strtab (make-string-table))
+ (bv (make-bytevector size 0)))
+ (define (intern-string! name)
+ (call-with-values
+ (lambda () (string-table-intern strtab (symbol->string name)))
+ (lambda (table idx)
+ (set! strtab table)
+ idx)))
+ (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
+ intern-string!)))))
+ (let ((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 '()
+ #:type SHT_PROGBITS #:flags 0
+ #:link (elf-section-index
+ (linker-object-section strtab)))
+ strtab)))))
+
(define (link-objects asm)
(let*-values (((ro rw rw-init) (link-constants asm))
;; Link text object after constants, so that the
@@ -975,10 +1171,13 @@
((text) (link-text-object asm))
((dt) (link-dynamic-section asm text ro rw rw-init))
((symtab strtab) (link-symtab (linker-object-section text) asm))
+ ((arities arities-strtab) (link-arities asm))
;; This needs to be linked last, because linking other
;; sections adds entries to the string table.
((shstrtab) (link-shstrtab asm)))
- (filter identity (list text ro rw dt symtab strtab shstrtab))))
+ (filter identity
+ (list text ro rw dt symtab strtab arities arities-strtab
+ shstrtab))))
(define (link-assembly asm)
(link-elf (link-objects asm)))
--
1.7.10.4
^ permalink raw reply related [flat|nested] 11+ messages in thread* [PATCH 5/9] (system vm debug) can read arity information
2013-06-04 14:44 Serialize procedure metadata into ELF for RTL programs Andy Wingo
` (3 preceding siblings ...)
2013-06-04 14:44 ` [PATCH 4/9] RTL assembler writes arities information into separate section Andy Wingo
@ 2013-06-04 14:44 ` Andy Wingo
2013-06-04 14:44 ` [PATCH 6/9] Wire up ability to print RTL program arities Andy Wingo
` (3 subsequent siblings)
8 siblings, 0 replies; 11+ messages in thread
From: Andy Wingo @ 2013-06-04 14:44 UTC (permalink / raw)
To: guile-devel; +Cc: Andy Wingo
* module/system/vm/assembler.scm (write-arity-headers): Fill in the
prefix.
* module/system/vm/debug.scm (<arity>): New object, for reading
arities. Unlike <arity> in the assembler, this one only holds on to a
couple of pointers, and doesn't even load in argument names. Unlike
the arity lists in (system vm program), it can load in names. Very
early days but it does seem to work.
(find-program-arities, arity-arguments-alist): New higher-level
interfaces.
---
module/system/vm/assembler.scm | 5 +-
module/system/vm/debug.scm | 174 +++++++++++++++++++++++++++++++++++++++-
2 files changed, 177 insertions(+), 2 deletions(-)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 342b3dc..7718574 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1073,7 +1073,10 @@
(length (arity-opt arity))))
(let lp ((metas metas) (pos arities-prefix-len) (offsets '()))
(match metas
- (() (values pos (reverse offsets)))
+ (()
+ ;; Fill in the prefix.
+ (bytevector-u32-set! bv 0 pos endianness)
+ (values pos (reverse offsets)))
((meta . metas)
(match (meta-arities meta)
(() (lp metas pos offsets))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index d7d62da..724f2b4 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -36,8 +36,20 @@
program-debug-info-u32-offset
program-debug-info-u32-offset-end
+ arity?
+ arity-low-pc
+ arity-high-pc
+ arity-nreq
+ arity-nopt
+ arity-has-rest?
+ arity-allow-other-keys?
+ arity-has-keyword-args?
+ arity-is-case-lambda?
+
find-debug-context
- find-program-debug-info))
+ find-program-debug-info
+ arity-arguments-alist
+ find-program-arities))
(define-record-type <debug-context>
(make-debug-context elf base text-base)
@@ -135,3 +147,163 @@
(elf-symbol-value sym)
(elf-symbol-size sym))))
(else #f)))
+
+(define-record-type <arity>
+ (make-arity context base header-offset)
+ arity?
+ (context arity-context)
+ (base arity-base)
+ (header-offset arity-header-offset))
+
+(define arities-prefix-len 4)
+(define arity-header-len (* 6 4))
+
+;;; struct arity_header {
+;;; uint32_t low_pc;
+;;; uint32_t high_pc;
+;;; uint32_t offset;
+;;; uint32_t flags;
+;;; uint32_t nreq;
+;;; uint32_t nopt;
+;;; }
+
+(define (arity-low-pc* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 0 4))))
+(define (arity-high-pc* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 1 4))))
+(define (arity-offset* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 2 4))))
+(define (arity-flags* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 3 4))))
+(define (arity-nreq* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 4 4))))
+(define (arity-nopt* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 5 4))))
+
+;;; #x1: has-rest?
+;;; #x2: allow-other-keys?
+;;; #x4: has-keyword-args?
+;;; #x8: is-case-lambda?
+
+(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 (arity-nreq arity)
+ (arity-nreq* (elf-bytes (debug-context-elf (arity-context arity)))
+ (arity-header-offset arity)))
+
+(define (arity-nopt arity)
+ (arity-nopt* (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)))
+
+(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)))
+(define (arity-is-case-lambda? arity) (is-case-lambda? (arity-flags arity)))
+
+(define (arity-load-symbol arity)
+ (let ((elf (debug-context-elf (arity-context arity))))
+ (cond
+ ((elf-section-by-name elf ".guile.arities")
+ =>
+ (lambda (sec)
+ (let* ((strtab (elf-section elf (elf-section-link sec)))
+ (bv (elf-bytes elf))
+ (strtab-offset (elf-section-offset strtab)))
+ (lambda (n)
+ (string->symbol (string-table-ref bv (+ strtab-offset n)))))))
+ (else (error "couldn't find arities section")))))
+
+(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)))
+ (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))
+ (rest . ,(and (has-rest? flags) (load-symbol (+ 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))))))
+
+(define (find-first-arity context base addr)
+ (let* ((bv (elf-bytes (debug-context-elf context)))
+ (text-offset (- addr
+ (debug-context-text-base context)
+ (debug-context-base context)))
+ (headers-start (+ base arities-prefix-len))
+ (headers-end (+ base (bytevector-u32-native-ref bv base))))
+ ;; FIXME: This is linear search. Change to binary search.
+ (let lp ((pos headers-start))
+ (cond
+ ((>= pos headers-end) #f)
+ ((< text-offset (arity-low-pc* bv pos))
+ (lp (+ pos arity-header-len)))
+ ((< (arity-high-pc* bv pos) text-offset)
+ #f)
+ (else
+ (make-arity context base pos))))))
+
+(define (read-sub-arities context base outer-header-offset)
+ (let* ((bv (elf-bytes (debug-context-elf context)))
+ (headers-end (+ base (bytevector-u32-native-ref bv base)))
+ (low-pc (arity-low-pc* bv outer-header-offset))
+ (high-pc (arity-high-pc* bv outer-header-offset)))
+ (let lp ((pos (+ outer-header-offset arity-header-len)) (out '()))
+ (if (and (< pos headers-end) (<= (arity-high-pc* bv pos) high-pc))
+ (lp (+ pos arity-header-len)
+ (cons (make-arity context base pos) out))
+ (reverse out)))))
+
+(define* (find-program-arities addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (elf-section-by-name (debug-context-elf context) ".guile.arities")
+ (lambda (sec)
+ (let* ((base (elf-section-offset sec))
+ (first (find-first-arity context base addr)))
+ ;; FIXME: Handle case-lambda arities.
+ (cond
+ ((not first) '())
+ ((arity-is-case-lambda? first)
+ (read-sub-arities context base (arity-header-offset first)))
+ (else (list first)))))))
+
+(define* (program-minimum-arity addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (elf-section-by-name (debug-context-elf context) ".guile.arities")
+ (lambda (sec)
+ (let* ((base (elf-section-offset sec))
+ (first (find-first-arity context base addr)))
+ (if (arity-is-case-lambda? first)
+ (list 0 0 #t) ;; FIXME: be more precise.
+ (list (arity-nreq first)
+ (arity-nopt first)
+ (arity-has-rest? first)))))))
--
1.7.10.4
^ permalink raw reply related [flat|nested] 11+ messages in thread* [PATCH 6/9] Wire up ability to print RTL program arities
2013-06-04 14:44 Serialize procedure metadata into ELF for RTL programs Andy Wingo
` (4 preceding siblings ...)
2013-06-04 14:44 ` [PATCH 5/9] (system vm debug) can read arity information Andy Wingo
@ 2013-06-04 14:44 ` Andy Wingo
2013-06-04 14:44 ` [PATCH 7/9] Write docstrings into RTL ELF images Andy Wingo
` (2 subsequent siblings)
8 siblings, 0 replies; 11+ messages in thread
From: Andy Wingo @ 2013-06-04 14:44 UTC (permalink / raw)
To: guile-devel; +Cc: Andy Wingo
* libguile/procprop.c (scm_i_procedure_arity): Allow RTL programs to
dispatch to scm_i_program_arity.
* libguile/programs.c (scm_i_program_print): Refactor reference to
write-program.
(scm_i_rtl_program_minimum_arity): New procedure, dispatches to
Scheme.
(scm_i_program_arity): Dispatch to scm_i_rtl_program_minimum_arity if
appropriate.
* module/system/vm/debug.scm (program-minimum-arity): New export.
* module/system/vm/program.scm (rtl-program-minimum-arity): New internal
function.
(program-arguments-alists): New helper, implemented also for RTL
procedures.
(write-program): Refactor a bit, and call program-arguments-alists.
* test-suite/tests/rtl.test ("simply procedure arity"): Add tests that
arities make it all the way to cold ELF and back to warm Guile.
---
libguile/procprop.c | 10 +------
libguile/programs.c | 30 ++++++++++++++++++---
module/system/vm/debug.scm | 3 ++-
module/system/vm/program.scm | 59 ++++++++++++++++++++++++++++--------------
test-suite/tests/rtl.test | 30 +++++++++++++++++++++
5 files changed, 99 insertions(+), 33 deletions(-)
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 4809702..62476c0 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -60,7 +60,7 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
return 1;
}
- while (!SCM_PROGRAM_P (proc))
+ while (!SCM_PROGRAM_P (proc) && !SCM_RTL_PROGRAM_P (proc))
{
if (SCM_STRUCTP (proc))
{
@@ -82,14 +82,6 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
return 1;
}
- else if (SCM_RTL_PROGRAM_P (proc))
- {
- *req = 0;
- *opt = 0;
- *rest = 1;
-
- return 1;
- }
else
return 0;
}
diff --git a/libguile/programs.c b/libguile/programs.c
index d356915..12561b3 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -129,9 +129,8 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
static int print_error = 0;
if (scm_is_false (write_program) && scm_module_system_booted_p)
- write_program = scm_module_local_variable
- (scm_c_resolve_module ("system vm program"),
- scm_from_latin1_symbol ("write-program"));
+ write_program = scm_c_private_variable ("system vm program",
+ "write-program");
if (SCM_PROGRAM_IS_CONTINUATION (program))
{
@@ -450,11 +449,36 @@ parse_arity (SCM arity, int *req, int *opt, int *rest)
*req = *opt = *rest = 0;
}
+static int
+scm_i_rtl_program_minimum_arity (SCM program, int *req, int *opt, int *rest)
+{
+ static SCM rtl_program_minimum_arity = SCM_BOOL_F;
+ SCM l;
+
+ if (scm_is_false (rtl_program_minimum_arity) && scm_module_system_booted_p)
+ rtl_program_minimum_arity =
+ scm_c_private_variable ("system vm debug",
+ "rtl-program-minimum-arity");
+
+ l = scm_call_1 (scm_variable_ref (rtl_program_minimum_arity), program);
+ if (scm_is_false (l))
+ return 0;
+
+ *req = scm_to_int (scm_car (l));
+ *opt = scm_to_int (scm_cadr (l));
+ *rest = scm_is_true (scm_caddr (l));
+
+ return 1;
+}
+
int
scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
{
SCM arities;
+ if (SCM_RTL_PROGRAM_P (program))
+ return scm_i_rtl_program_minimum_arity (program, req, opt, rest);
+
arities = scm_program_arities (program);
if (!scm_is_pair (arities))
return 0;
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 724f2b4..81e2250 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -49,7 +49,8 @@
find-debug-context
find-program-debug-info
arity-arguments-alist
- find-program-arities))
+ find-program-arities
+ program-minimum-arity))
(define-record-type <debug-context>
(make-debug-context elf base text-base)
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index fdfc9a8..a4bd64e 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -61,6 +61,12 @@
(and=> (find-program-debug-info (rtl-program-code program))
program-debug-info-name))
+;; This procedure is called by programs.c.
+(define (rtl-program-minimum-arity program)
+ (unless (rtl-program? program)
+ (error "shouldn't get here"))
+ (program-minimum-arity (rtl-program-code program)))
+
(define (make-binding name boxed? index start end)
(list name boxed? index start end))
(define (binding:name b) (list-ref b 0))
@@ -276,25 +282,38 @@
1+
0)))
+(define (program-arguments-alists prog)
+ (cond
+ ((rtl-program? prog)
+ (map arity-arguments-alist
+ (find-program-arities (rtl-program-code prog))))
+ ((program? prog)
+ (map (lambda (arity) (arity->arguments-alist prog arity))
+ (or (program-arities prog) '())))
+ (else (error "expected a program" prog))))
+
(define (write-program prog port)
- (format port "#<procedure ~a~a>"
- (or (procedure-name prog)
- (and=> (and (program? prog) (program-source prog 0))
- (lambda (s)
- (format #f "~a at ~a:~a:~a"
- (number->string (object-address prog) 16)
- (or (source:file s)
- (if s "<current input>" "<unknown port>"))
- (source:line-for-user s) (source:column s))))
- (number->string (object-address prog) 16))
- (let ((arities (and (program? prog) (program-arities prog))))
- (if (or (not arities) (null? arities))
- ""
- (string-append
- " " (string-join (map (lambda (a)
- (object->string
- (arguments-alist->lambda-list
- (arity->arguments-alist prog a))))
- arities)
- " | "))))))
+ (define (program-identity-string)
+ (or (procedure-name prog)
+ (and=> (and (program? prog) (program-source prog 0))
+ (lambda (s)
+ (format #f "~a at ~a:~a:~a"
+ (number->string (object-address prog) 16)
+ (or (source:file s)
+ (if s "<current input>" "<unknown port>"))
+ (source:line-for-user s) (source:column s))))
+ (number->string (object-address prog) 16)))
+ (define (program-formals-string)
+ (let ((arguments (program-arguments-alists prog)))
+ (if (null? arguments)
+ ""
+ (string-append
+ " " (string-join (map (lambda (a)
+ (object->string
+ (arguments-alist->lambda-list a)))
+ arguments)
+ " | ")))))
+
+ (format port "#<procedure ~a~a>"
+ (program-identity-string) (program-formals-string)))
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 1813969..c50aae9 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -316,3 +316,33 @@
(return 0)
(end-arity)
(end-program))))))
+
+(with-test-prefix "simply procedure arity"
+ (pass-if-equal "#<procedure foo ()>"
+ (object->string
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-standard-arity () 1 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program)))))
+ (pass-if-equal "#<procedure foo (x y)>"
+ (object->string
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-standard-arity (x y) 2 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program)))))
+
+ (pass-if-equal "#<procedure foo (x #:optional y . z)>"
+ (object->string
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-opt-arity (x) (y) z 3 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program))))))
--
1.7.10.4
^ permalink raw reply related [flat|nested] 11+ messages in thread* [PATCH 7/9] Write docstrings into RTL ELF images
2013-06-04 14:44 Serialize procedure metadata into ELF for RTL programs Andy Wingo
` (5 preceding siblings ...)
2013-06-04 14:44 ` [PATCH 6/9] Wire up ability to print RTL program arities Andy Wingo
@ 2013-06-04 14:44 ` Andy Wingo
2013-06-04 14:44 ` [PATCH 8/9] procedure-documentation works on RTL procedures Andy Wingo
2013-06-04 14:44 ` [PATCH 9/9] procedure-properties for RTL functions Andy Wingo
8 siblings, 0 replies; 11+ messages in thread
From: Andy Wingo @ 2013-06-04 14:44 UTC (permalink / raw)
To: guile-devel; +Cc: Andy Wingo
* module/system/vm/assembler.scm (link-docstrs): Write docstrings.
(link-objects): Link docstrings into the ELF.
---
module/system/vm/assembler.scm | 58 +++++++++++++++++++++++++++++++++++++++-
1 file changed, 57 insertions(+), 1 deletion(-)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 7718574..3fe4692 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1167,6 +1167,61 @@
(linker-object-section strtab)))
strtab)))))
+;;;
+;;; The .guile.docstrs section is a packed, sorted array of (pc, str)
+;;; values. Pc and str are both 32 bits wide. (Either could change to
+;;; 64 bits if appropriate in the future.) Pc is the address of the
+;;; entry to a program, relative to the start of the text section, and
+;;; str is an index into the associated .guile.docstrs.strtab string
+;;; table section.
+;;;
+
+;; The size of a docstrs entry, in bytes.
+(define docstr-size 8)
+
+(define (link-docstrs asm)
+ (define (find-docstrings)
+ (filter-map (lambda (meta)
+ (define (is-documentation? pair)
+ (eq? (car pair) 'documentation))
+ (let* ((props (meta-properties meta))
+ (tail (find-tail is-documentation? props)))
+ (and tail
+ (not (find-tail is-documentation? (cdr tail)))
+ (string? (cdar tail))
+ (cons (meta-low-pc meta) (cdar tail)))))
+ (reverse (asm-meta asm))))
+ (let* ((endianness (asm-endianness asm))
+ (docstrings (find-docstrings))
+ (strtab (make-string-table))
+ (bv (make-bytevector (* (length docstrings) docstr-size) 0)))
+ (define (intern-string! name)
+ (call-with-values
+ (lambda () (string-table-intern strtab name))
+ (lambda (table idx)
+ (set! strtab table)
+ idx)))
+ (fold (lambda (pair pos)
+ (match pair
+ ((pc . string)
+ (bytevector-u32-set! bv pos pc endianness)
+ (bytevector-u32-set! bv (+ pos 4) (intern-string! string)
+ endianness)
+ (+ pos docstr-size))))
+ 0
+ docstrings)
+ (let ((strtab (make-object asm '.guile.docstrs.strtab
+ (link-string-table strtab)
+ '() '()
+ #:type SHT_STRTAB #:flags 0)))
+ (values (make-object asm '.guile.docstrs
+ bv
+ '() '()
+ #:type SHT_PROGBITS #:flags 0
+ #:link (elf-section-index
+ (linker-object-section strtab)))
+ strtab))))
+
(define (link-objects asm)
(let*-values (((ro rw rw-init) (link-constants asm))
;; Link text object after constants, so that the
@@ -1175,12 +1230,13 @@
((dt) (link-dynamic-section asm text ro rw rw-init))
((symtab strtab) (link-symtab (linker-object-section text) asm))
((arities arities-strtab) (link-arities asm))
+ ((docstrs docstrs-strtab) (link-docstrs asm))
;; This needs to be linked last, because linking other
;; sections adds entries to the string table.
((shstrtab) (link-shstrtab asm)))
(filter identity
(list text ro rw dt symtab strtab arities arities-strtab
- shstrtab))))
+ docstrs docstrs-strtab shstrtab))))
(define (link-assembly asm)
(link-elf (link-objects asm)))
--
1.7.10.4
^ permalink raw reply related [flat|nested] 11+ messages in thread* [PATCH 8/9] procedure-documentation works on RTL procedures
2013-06-04 14:44 Serialize procedure metadata into ELF for RTL programs Andy Wingo
` (6 preceding siblings ...)
2013-06-04 14:44 ` [PATCH 7/9] Write docstrings into RTL ELF images Andy Wingo
@ 2013-06-04 14:44 ` Andy Wingo
2013-06-04 14:44 ` [PATCH 9/9] procedure-properties for RTL functions Andy Wingo
8 siblings, 0 replies; 11+ messages in thread
From: Andy Wingo @ 2013-06-04 14:44 UTC (permalink / raw)
To: guile-devel; +Cc: Andy Wingo
* libguile/procprop.h:
* libguile/procprop.c (scm_procedure_documentation): Move here from
procs.c, and to make the logic more similar to that of procedure-name,
which allows RTL programs to dispatch to rtl-program-documentation.
* libguile/programs.c (scm_i_rtl_program_documentation):
* libguile/programs.h:
* module/system/vm/program.scm (rtl-program-documentation): New
plumbing.
* module/system/vm/debug.scm (find-program-docstring): New interface to
grovel ELF for a docstring.
---
libguile/procprop.c | 33 +++++++++++++++++++++++++++++++++
libguile/procprop.h | 2 ++
libguile/procs.c | 15 ---------------
libguile/procs.h | 5 +----
libguile/programs.c | 13 +++++++++++++
libguile/programs.h | 1 +
module/system/vm/debug.scm | 34 +++++++++++++++++++++++++++++++++-
module/system/vm/program.scm | 6 ++++++
test-suite/tests/rtl.test | 11 +++++++++++
9 files changed, 100 insertions(+), 20 deletions(-)
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 62476c0..d7ce09b 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -238,6 +238,39 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
#undef FUNC_NAME
+SCM_GLOBAL_SYMBOL (scm_sym_documentation, "documentation");
+
+SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
+ (SCM proc),
+ "Return the documentation string associated with @code{proc}. By\n"
+ "convention, if a procedure contains more than one expression and the\n"
+ "first expression is a string constant, that string is assumed to contain\n"
+ "documentation for that procedure.")
+#define FUNC_NAME s_scm_procedure_documentation
+{
+ SCM props, ret;
+
+ SCM_VALIDATE_PROC (1, proc);
+
+ while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
+ proc = SCM_STRUCT_PROCEDURE (proc);
+
+ props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+
+ if (scm_is_pair (props))
+ ret = scm_assq_ref (props, scm_sym_documentation);
+ else if (SCM_RTL_PROGRAM_P (proc))
+ ret = scm_i_rtl_program_documentation (proc);
+ else if (SCM_PROGRAM_P (proc))
+ ret = scm_assq_ref (scm_i_program_properties (proc), scm_sym_documentation);
+ else
+ ret = SCM_BOOL_F;
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
(SCM proc),
"Return the source of the procedure @var{proc}.")
diff --git a/libguile/procprop.h b/libguile/procprop.h
index 13fbe46..41d0753 100644
--- a/libguile/procprop.h
+++ b/libguile/procprop.h
@@ -29,6 +29,7 @@
SCM_API SCM scm_sym_name;
SCM_API SCM scm_sym_system_procedure;
+SCM_INTERNAL SCM scm_sym_documentation;
\f
@@ -42,6 +43,7 @@ SCM_API SCM scm_procedure_property (SCM proc, SCM key);
SCM_API SCM scm_set_procedure_property_x (SCM proc, SCM key, SCM val);
SCM_API SCM scm_procedure_source (SCM proc);
SCM_API SCM scm_procedure_name (SCM proc);
+SCM_API SCM scm_procedure_documentation (SCM proc);
SCM_INTERNAL void scm_init_procprop (void);
#endif /* SCM_PROCPROP_H */
diff --git a/libguile/procs.c b/libguile/procs.c
index bda6d34..8d9ef15 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -66,21 +66,6 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_GLOBAL_SYMBOL (scm_sym_documentation, "documentation");
-
-SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
- (SCM proc),
- "Return the documentation string associated with @code{proc}. By\n"
- "convention, if a procedure contains more than one expression and the\n"
- "first expression is a string constant, that string is assumed to contain\n"
- "documentation for that procedure.")
-#define FUNC_NAME s_scm_procedure_documentation
-{
- SCM_VALIDATE_PROC (SCM_ARG1, proc);
- return scm_procedure_property (proc, scm_sym_documentation);
-}
-#undef FUNC_NAME
-
/* Procedure-with-setter
*/
diff --git a/libguile/procs.h b/libguile/procs.h
index a35872e..c4c78f2 100644
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -4,7 +4,7 @@
#define SCM_PROCS_H
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2006, 2008, 2009,
- * 2012 Free Software Foundation, Inc.
+ * 2012, 2013 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 License
@@ -30,15 +30,12 @@
SCM_API SCM scm_procedure_p (SCM obj);
SCM_API SCM scm_thunk_p (SCM obj);
-SCM_API SCM scm_procedure_documentation (SCM proc);
SCM_API SCM scm_procedure_with_setter_p (SCM obj);
SCM_API SCM scm_make_procedure_with_setter (SCM procedure, SCM setter);
SCM_API SCM scm_procedure (SCM proc);
SCM_API SCM scm_setter (SCM proc);
SCM_INTERNAL void scm_init_procs (void);
-SCM_INTERNAL SCM scm_sym_documentation;
-
#endif /* SCM_PROCS_H */
/*
diff --git a/libguile/programs.c b/libguile/programs.c
index 12561b3..567708a 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -123,6 +123,19 @@ scm_i_rtl_program_name (SCM program)
return scm_call_1 (scm_variable_ref (rtl_program_name), program);
}
+SCM
+scm_i_rtl_program_documentation (SCM program)
+{
+ static SCM rtl_program_documentation = SCM_BOOL_F;
+
+ if (scm_is_false (rtl_program_documentation) && scm_module_system_booted_p)
+ rtl_program_documentation =
+ scm_c_private_variable ("system vm program",
+ "rtl-program-documentation");
+
+ return scm_call_1 (scm_variable_ref (rtl_program_documentation), program);
+}
+
void
scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
{
diff --git a/libguile/programs.h b/libguile/programs.h
index fa46135..175059f 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -45,6 +45,7 @@ SCM_INTERNAL SCM scm_rtl_program_p (SCM obj);
SCM_INTERNAL SCM scm_rtl_program_code (SCM program);
SCM_INTERNAL SCM scm_i_rtl_program_name (SCM program);
+SCM_INTERNAL SCM scm_i_rtl_program_documentation (SCM program);
/*
* Programs
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 81e2250..c8c2cdd 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -50,7 +50,9 @@
find-program-debug-info
arity-arguments-alist
find-program-arities
- program-minimum-arity))
+ program-minimum-arity
+
+ find-program-docstring))
(define-record-type <debug-context>
(make-debug-context elf base text-base)
@@ -308,3 +310,33 @@
(list (arity-nreq first)
(arity-nopt first)
(arity-has-rest? first)))))))
+
+(define* (find-program-docstring addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (elf-section-by-name (debug-context-elf context) ".guile.docstrs")
+ (lambda (sec)
+ ;; struct docstr {
+ ;; uint32_t pc;
+ ;; uint32_t str;
+ ;; }
+ (define docstr-len 8)
+ (let* ((start (elf-section-offset sec))
+ (end (+ start (elf-section-size sec)))
+ (bv (elf-bytes (debug-context-elf context)))
+ (text-offset (- addr
+ (debug-context-text-base context)
+ (debug-context-base context))))
+ ;; FIXME: This is linear search. Change to binary search.
+ (let lp ((pos start))
+ (cond
+ ((>= pos end) #f)
+ ((< text-offset (bytevector-u32-native-ref bv pos))
+ (lp (+ pos arity-header-len)))
+ ((> text-offset (bytevector-u32-native-ref bv pos))
+ #f)
+ (else
+ (let ((strtab (elf-section (debug-context-elf context)
+ (elf-section-link sec)))
+ (idx (bytevector-u32-native-ref bv (+ pos 4))))
+ (string-table-ref bv (+ (elf-section-offset strtab) idx))))))))))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index a4bd64e..d719e95 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -62,6 +62,12 @@
program-debug-info-name))
;; This procedure is called by programs.c.
+(define (rtl-program-documentation program)
+ (unless (rtl-program? program)
+ (error "shouldn't get here"))
+ (find-program-docstring (rtl-program-code program)))
+
+;; This procedure is called by programs.c.
(define (rtl-program-minimum-arity program)
(unless (rtl-program? program)
(error "shouldn't get here"))
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index c50aae9..8fcdb63 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -346,3 +346,14 @@
(return 0)
(end-arity)
(end-program))))))
+
+(with-test-prefix "procedure docstrings"
+ (pass-if-equal "qux qux"
+ (procedure-documentation
+ (assemble-program
+ '((begin-program foo ((name . foo) (documentation . "qux qux")))
+ (begin-standard-arity () 1 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program))))))
--
1.7.10.4
^ permalink raw reply related [flat|nested] 11+ messages in thread* [PATCH 9/9] procedure-properties for RTL functions
2013-06-04 14:44 Serialize procedure metadata into ELF for RTL programs Andy Wingo
` (7 preceding siblings ...)
2013-06-04 14:44 ` [PATCH 8/9] procedure-documentation works on RTL procedures Andy Wingo
@ 2013-06-04 14:44 ` Andy Wingo
2013-06-04 15:06 ` Nala Ginrut
8 siblings, 1 reply; 11+ messages in thread
From: Andy Wingo @ 2013-06-04 14:44 UTC (permalink / raw)
To: guile-devel; +Cc: Andy Wingo
* module/system/vm/assembler.scm (link-procprops, link-objects): Arrange
to write procedure property links out to a separate section.
* libguile/procprop.c (scm_procedure_properties):
* libguile/programs.h:
* libguile/programs.c (scm_i_rtl_program_properties):
* module/system/vm/debug.scm (find-program-properties): Wire up
procedure-properties for RTL procedures. Yeah! Fistpumps! :)
* module/system/vm/debug.scm (find-program-debug-info): Return #f if the
string is "", as it is if we don't have a name. Perhaps
elf-symbol-name should return #f in that case...
(find-program-docstring): Bugfix: increment by docstr-len.
* test-suite/tests/rtl.test: Add some tests.
---
libguile/procprop.c | 2 ++
libguile/programs.c | 12 ++++++++
libguile/programs.h | 1 +
module/system/vm/assembler.scm | 65 ++++++++++++++++++++++++++++++++++++++--
module/system/vm/debug.scm | 47 +++++++++++++++++++++++++++--
module/system/vm/program.scm | 10 +++----
test-suite/tests/rtl.test | 52 ++++++++++++++++++++++++++++++++
7 files changed, 180 insertions(+), 9 deletions(-)
diff --git a/libguile/procprop.c b/libguile/procprop.c
index d7ce09b..2d9e655 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -146,6 +146,8 @@ SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
{
if (SCM_PROGRAM_P (proc))
ret = scm_i_program_properties (proc);
+ else if (SCM_RTL_PROGRAM_P (proc))
+ ret = scm_i_rtl_program_properties (proc);
else
ret = SCM_EOL;
}
diff --git a/libguile/programs.c b/libguile/programs.c
index 567708a..d8dd378 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -136,6 +136,18 @@ scm_i_rtl_program_documentation (SCM program)
return scm_call_1 (scm_variable_ref (rtl_program_documentation), program);
}
+SCM
+scm_i_rtl_program_properties (SCM program)
+{
+ static SCM rtl_program_properties = SCM_BOOL_F;
+
+ if (scm_is_false (rtl_program_properties) && scm_module_system_booted_p)
+ rtl_program_properties =
+ scm_c_private_variable ("system vm program", "rtl-program-properties");
+
+ return scm_call_1 (scm_variable_ref (rtl_program_properties), program);
+}
+
void
scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
{
diff --git a/libguile/programs.h b/libguile/programs.h
index 175059f..e42a76e 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -46,6 +46,7 @@ SCM_INTERNAL SCM scm_rtl_program_code (SCM program);
SCM_INTERNAL SCM scm_i_rtl_program_name (SCM program);
SCM_INTERNAL SCM scm_i_rtl_program_documentation (SCM program);
+SCM_INTERNAL SCM scm_i_rtl_program_properties (SCM program);
/*
* Programs
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 3fe4692..0e1bbfc 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1222,8 +1222,69 @@
(linker-object-section strtab)))
strtab))))
+;;;
+;;; The .guile.procprops section is a packed, sorted array of (pc, addr)
+;;; values. Pc and addr are both 32 bits wide. (Either could change to
+;;; 64 bits if appropriate in the future.) Pc is the address of the
+;;; entry to a program, relative to the start of the text section, and
+;;; addr is the address of the associated properties alist, relative to
+;;; the start of the ELF image.
+;;;
+;;; Since procedure properties are stored in the data sections, we need
+;;; to link the procedures property section first. (Note that this
+;;; constraint does not apply to the arities section, which may
+;;; reference the data sections via the kw-indices literal, because
+;;; assembling the text section already makes sure that the kw-indices
+;;; are interned.)
+;;;
+
+;; The size of a procprops entry, in bytes.
+(define procprops-size 8)
+
+(define (link-procprops asm)
+ (define (assoc-remove-one alist key value-pred)
+ (match alist
+ (() '())
+ ((((? (lambda (x) (eq? x key))) . value) . alist)
+ (if (value-pred value)
+ alist
+ (acons key value alist)))
+ (((k . v) . alist)
+ (acons k v (assoc-remove-one alist key value-pred)))))
+ (define (props-without-name-or-docstring meta)
+ (assoc-remove-one
+ (assoc-remove-one (meta-properties meta) 'name (lambda (x) #t))
+ 'documentation
+ string?))
+ (define (find-procprops)
+ (filter-map (lambda (meta)
+ (let ((props (props-without-name-or-docstring meta)))
+ (and (pair? props)
+ (cons (meta-low-pc meta) props))))
+ (reverse (asm-meta asm))))
+ (let* ((endianness (asm-endianness asm))
+ (procprops (find-procprops))
+ (bv (make-bytevector (* (length procprops) procprops-size) 0)))
+ (let lp ((procprops procprops) (pos 0) (relocs '()))
+ (match procprops
+ (()
+ (make-object asm '.guile.procprops
+ bv
+ relocs '()
+ #:type SHT_PROGBITS #:flags 0))
+ (((pc . props) . procprops)
+ (bytevector-u32-set! bv pos pc endianness)
+ (lp procprops
+ (+ pos procprops-size)
+ (cons (make-linker-reloc 'abs32/1 (+ pos 4) 0
+ (intern-constant asm props))
+ relocs)))))))
+
(define (link-objects asm)
- (let*-values (((ro rw rw-init) (link-constants asm))
+ (let*-values (;; Link procprops before constants, because it probably
+ ;; interns more constants.
+ ((procprops) (link-procprops asm))
+ ((ro rw rw-init) (link-constants asm))
;; Link text object after constants, so that the
;; constants initializer gets included.
((text) (link-text-object asm))
@@ -1236,7 +1297,7 @@
((shstrtab) (link-shstrtab asm)))
(filter identity
(list text ro rw dt symtab strtab arities arities-strtab
- docstrs docstrs-strtab shstrtab))))
+ docstrs docstrs-strtab procprops shstrtab))))
(define (link-assembly asm)
(link-elf (link-objects asm)))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index c8c2cdd..15c37f4 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -52,7 +52,9 @@
find-program-arities
program-minimum-arity
- find-program-docstring))
+ find-program-docstring
+
+ find-program-properties))
(define-record-type <debug-context>
(make-debug-context elf base text-base)
@@ -332,7 +334,7 @@
(cond
((>= pos end) #f)
((< text-offset (bytevector-u32-native-ref bv pos))
- (lp (+ pos arity-header-len)))
+ (lp (+ pos docstr-len)))
((> text-offset (bytevector-u32-native-ref bv pos))
#f)
(else
@@ -340,3 +342,44 @@
(elf-section-link sec)))
(idx (bytevector-u32-native-ref bv (+ pos 4))))
(string-table-ref bv (+ (elf-section-offset strtab) idx))))))))))
+
+(define* (find-program-properties addr #:optional
+ (context (find-debug-context addr)))
+ (define (add-name-and-docstring props)
+ (define (maybe-acons k v tail)
+ (if v (acons k v tail) tail))
+ (let ((name (and=> (find-program-debug-info addr context)
+ program-debug-info-name))
+ (docstring (find-program-docstring addr context)))
+ (maybe-acons 'name name
+ (maybe-acons 'documentation docstring props))))
+ (add-name-and-docstring
+ (cond
+ ((elf-section-by-name (debug-context-elf context) ".guile.procprops")
+ => (lambda (sec)
+ ;; struct procprop {
+ ;; uint32_t pc;
+ ;; uint32_t offset;
+ ;; }
+ (define procprop-len 8)
+ (let* ((start (elf-section-offset sec))
+ (end (+ start (elf-section-size sec)))
+ (bv (elf-bytes (debug-context-elf context)))
+ (text-offset (- addr
+ (debug-context-text-base context)
+ (debug-context-base context))))
+ (define (unpack-scm addr)
+ (pointer->scm (make-pointer addr)))
+ (define (load-non-immediate offset)
+ (unpack-scm (+ (debug-context-base context) offset)))
+ ;; FIXME: This is linear search. Change to binary search.
+ (let lp ((pos start))
+ (cond
+ ((>= pos end) '())
+ ((< text-offset (bytevector-u32-native-ref bv pos))
+ (lp (+ pos procprop-len)))
+ ((> text-offset (bytevector-u32-native-ref bv pos))
+ '())
+ (else
+ (load-non-immediate
+ (bytevector-u32-native-ref bv (+ pos 4))))))))))))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index d719e95..267e373 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -54,24 +54,24 @@
(load-extension (string-append "libguile-" (effective-version))
"scm_init_programs")
-;; This procedure is called by programs.c.
+;; These procedures are called by programs.c.
(define (rtl-program-name program)
(unless (rtl-program? program)
(error "shouldn't get here"))
(and=> (find-program-debug-info (rtl-program-code program))
program-debug-info-name))
-
-;; This procedure is called by programs.c.
(define (rtl-program-documentation program)
(unless (rtl-program? program)
(error "shouldn't get here"))
(find-program-docstring (rtl-program-code program)))
-
-;; This procedure is called by programs.c.
(define (rtl-program-minimum-arity program)
(unless (rtl-program? program)
(error "shouldn't get here"))
(program-minimum-arity (rtl-program-code program)))
+(define (rtl-program-properties program)
+ (unless (rtl-program? program)
+ (error "shouldn't get here"))
+ (find-program-properties (rtl-program-code program)))
(define (make-binding name boxed? index start end)
(list name boxed? index start end))
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 8fcdb63..0e38a8e 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -357,3 +357,55 @@
(return 0)
(end-arity)
(end-program))))))
+
+(with-test-prefix "procedure properties"
+ ;; No properties.
+ (pass-if-equal '()
+ (procedure-properties
+ (assemble-program
+ '((begin-program foo ())
+ (begin-standard-arity () 1 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program)))))
+
+ ;; Name and docstring (which actually don't go out to procprops).
+ (pass-if-equal '((name . foo)
+ (documentation . "qux qux"))
+ (procedure-properties
+ (assemble-program
+ '((begin-program foo ((name . foo) (documentation . "qux qux")))
+ (begin-standard-arity () 1 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program)))))
+
+ ;; A property that actually needs serialization.
+ (pass-if-equal '((name . foo)
+ (documentation . "qux qux")
+ (moo . "mooooooooooooo"))
+ (procedure-properties
+ (assemble-program
+ '((begin-program foo ((name . foo)
+ (documentation . "qux qux")
+ (moo . "mooooooooooooo")))
+ (begin-standard-arity () 1 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program)))))
+
+ ;; Procedure-name still works in this case.
+ (pass-if-equal 'foo
+ (procedure-name
+ (assemble-program
+ '((begin-program foo ((name . foo)
+ (documentation . "qux qux")
+ (moo . "mooooooooooooo")))
+ (begin-standard-arity () 1 #f)
+ (load-constant 0 42)
+ (return 0)
+ (end-arity)
+ (end-program))))))
--
1.7.10.4
^ permalink raw reply related [flat|nested] 11+ messages in thread