[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH 3/9] Beginnings of tracking of procedure arities in assembler
|
From: |
Andy Wingo |
|
Subject: |
[PATCH 3/9] Beginnings of tracking of procedure arities in assembler |
|
Date: |
Tue, 4 Jun 2013 16:44:04 +0200 |
* 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
- Serialize procedure metadata into ELF for RTL programs, Andy Wingo, 2013/06/04
- [PATCH 2/9] add procedure prelude macro-instructions, Andy Wingo, 2013/06/04
- [PATCH 3/9] Beginnings of tracking of procedure arities in assembler,
Andy Wingo <=
- [PATCH 1/9] begin-program takes properties alist, Andy Wingo, 2013/06/04
- [PATCH 4/9] RTL assembler writes arities information into separate section., Andy Wingo, 2013/06/04
- [PATCH 6/9] Wire up ability to print RTL program arities, Andy Wingo, 2013/06/04
- [PATCH 5/9] (system vm debug) can read arity information, Andy Wingo, 2013/06/04
- [PATCH 7/9] Write docstrings into RTL ELF images, Andy Wingo, 2013/06/04
- [PATCH 8/9] procedure-documentation works on RTL procedures, Andy Wingo, 2013/06/04
- [PATCH 9/9] procedure-properties for RTL functions, Andy Wingo, 2013/06/04