diff options
author | Andy Wingo <wingo@pobox.com> | 2013-05-14 11:18:05 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-06-09 23:37:46 +0200 |
commit | 3185c9071c93c4c7322f4f4484f20e038de4fdf1 (patch) | |
tree | 7d96c06d40fbda777283b0774f9c7167a76d46c5 | |
parent | 07c052796d6fcf056d172b311a87519996937fd0 (diff) | |
download | guile-3185c9071c93c4c7322f4f4484f20e038de4fdf1.tar.gz |
Beginnings of tracking of procedure arities in assembler
* 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.
-rw-r--r-- | module/system/vm/assembler.scm | 59 | ||||
-rw-r--r-- | 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 b5b2db8eb..5969dbf8b 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -122,21 +122,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) (assert-match label (? symbol?) "symbol") (assert-match 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)) ;;; An assembler collects all of the words emitted during assembly, and @@ -624,7 +638,44 @@ returned instead." (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) + (assert-match req ((? symbol?) ...) "list of symbols") + (assert-match opt ((? symbol?) ...) "list of symbols") + (assert-match rest (or #f (? symbol?)) "#f or symbol") + (assert-match kw-indices (((? symbol?) . (? integer?)) ...) + "alist of symbol -> integer") + (assert-match allow-other-keys? (? boolean?) "boolean") + (assert-match nlocals (? integer?) "integer") + (assert-match 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 02e699399..18139697f 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)))))) |