mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-01 23:30:28 +02:00
Code Activity

add procedure prelude macro-instructions

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2013-05-14 10:33:43 +02:00
parent 2a4daafd30
commit 07c052796d
2 changed files with 68 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -90,6 +90,12 @@
(define-syntax-rule (pack-u8-u8-u8-u8 x y z w) (define-syntax-rule (pack-u8-u8-u8-u8 x y z w)
(logior x (ash y 8) (ash z 16) (ash w 24))) (logior x (ash y 8) (ash z 16) (ash w 24)))
(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)))))
;;; Helpers to read and write 32-bit units in a buffer. ;;; Helpers to read and write 32-bit units in a buffer.
(define-syntax-rule (u32-ref buf n) (define-syntax-rule (u32-ref buf n)
@ -620,6 +626,48 @@ returned instead."
(let ((meta (car (asm-meta asm)))) (let ((meta (car (asm-meta asm))))
(set-meta-high-pc! meta (asm-start 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) (define-macro-assembler (label asm sym)
(set-asm-labels! asm (acons sym (asm-start asm) (asm-labels asm)))) (set-asm-labels! asm (acons sym (asm-start asm) (asm-labels asm))))

40
test-suite/tests/rtl.test
View file

@ -29,7 +29,7 @@
(define (return-constant val) (define (return-constant val)
(assemble-program `((begin-program foo (assemble-program `((begin-program foo
((name . foo))) ((name . foo)))
(assert-nargs-ee/locals 0 1) (standard-prelude 0 1 #f)
(load-constant 0 ,val) (load-constant 0 ,val)
(return 0) (return 0)
(end-program)))) (end-program))))
@ -66,13 +66,13 @@
(assert-equal 42 (assert-equal 42
(((assemble-program `((begin-program foo (((assemble-program `((begin-program foo
((name . foo))) ((name . foo)))
(assert-nargs-ee/locals 0 1) (standard-prelude 0 1 #f)
(load-static-procedure 0 bar) (load-static-procedure 0 bar)
(return 0) (return 0)
(end-program) (end-program)
(begin-program bar (begin-program bar
((name . bar))) ((name . bar)))
(assert-nargs-ee/locals 0 1) (standard-prelude 0 1 #f)
(load-constant 0 42) (load-constant 0 42)
(return 0) (return 0)
(end-program))))))) (end-program)))))))
@ -86,7 +86,7 @@
;; 2: accum ;; 2: accum
'((begin-program countdown '((begin-program countdown
((name . countdown))) ((name . countdown)))
(assert-nargs-ee/locals 1 2) (standard-prelude 1 3 #f)
(br fix-body) (br fix-body)
(label loop-head) (label loop-head)
(br-if-= 1 0 out) (br-if-= 1 0 out)
@ -111,7 +111,7 @@
;; 2: head ;; 2: head
'((begin-program make-accum '((begin-program make-accum
((name . make-accum))) ((name . make-accum)))
(assert-nargs-ee/locals 0 2) (standard-prelude 0 2 #f)
(load-constant 0 0) (load-constant 0 0)
(box 0 0) (box 0 0)
(make-closure 1 accum (0)) (make-closure 1 accum (0))
@ -119,7 +119,7 @@
(end-program) (end-program)
(begin-program accum (begin-program accum
((name . accum))) ((name . accum)))
(assert-nargs-ee/locals 1 2) (standard-prelude 1 3 #f)
(free-ref 1 0) (free-ref 1 0)
(box-ref 2 1) (box-ref 2 1)
(add 2 2 0) (add 2 2 0)
@ -137,7 +137,7 @@
(assemble-program (assemble-program
'((begin-program call '((begin-program call
((name . call))) ((name . call)))
(assert-nargs-ee/locals 1 0) (standard-prelude 1 1 #f)
(call 1 0 ()) (call 1 0 ())
(return 1) ;; MVRA from call (return 1) ;; MVRA from call
(return 1) ;; RA from call (return 1) ;; RA from call
@ -149,7 +149,7 @@
(assemble-program (assemble-program
'((begin-program call-with-3 '((begin-program call-with-3
((name . call-with-3))) ((name . call-with-3)))
(assert-nargs-ee/locals 1 1) (standard-prelude 1 2 #f)
(load-constant 1 3) (load-constant 1 3)
(call 2 0 (1)) (call 2 0 (1))
(return 2) ;; MVRA from call (return 2) ;; MVRA from call
@ -163,7 +163,7 @@
(assemble-program (assemble-program
'((begin-program call '((begin-program call
((name . call))) ((name . call)))
(assert-nargs-ee/locals 1 0) (standard-prelude 1 1 #f)
(tail-call 0 0) (tail-call 0 0)
(end-program))))) (end-program)))))
(call (lambda () 3)))) (call (lambda () 3))))
@ -173,7 +173,7 @@
(assemble-program (assemble-program
'((begin-program call-with-3 '((begin-program call-with-3
((name . call-with-3))) ((name . call-with-3)))
(assert-nargs-ee/locals 1 1) (standard-prelude 1 2 #f)
(mov 1 0) ;; R1 <- R0 (mov 1 0) ;; R1 <- R0
(load-constant 0 3) ;; R0 <- 3 (load-constant 0 3) ;; R0 <- 3
(tail-call 1 1) (tail-call 1 1)
@ -186,7 +186,7 @@
(assemble-program (assemble-program
'((begin-program get-sqrt-trampoline '((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline))) ((name . get-sqrt-trampoline)))
(assert-nargs-ee/locals 0 1) (standard-prelude 0 1 #f)
(cache-current-module! 0 sqrt-scope) (cache-current-module! 0 sqrt-scope)
(load-static-procedure 0 sqrt-trampoline) (load-static-procedure 0 sqrt-trampoline)
(return 0) (return 0)
@ -194,7 +194,7 @@
(begin-program sqrt-trampoline (begin-program sqrt-trampoline
((name . sqrt-trampoline))) ((name . sqrt-trampoline)))
(assert-nargs-ee/locals 1 1) (standard-prelude 1 2 #f)
(cached-toplevel-ref 1 sqrt-scope sqrt) (cached-toplevel-ref 1 sqrt-scope sqrt)
(tail-call 1 1) (tail-call 1 1)
(end-program))))) (end-program)))))
@ -209,7 +209,7 @@
(assemble-program (assemble-program
'((begin-program make-top-incrementor '((begin-program make-top-incrementor
((name . make-top-incrementor))) ((name . make-top-incrementor)))
(assert-nargs-ee/locals 0 1) (standard-prelude 0 1 #f)
(cache-current-module! 0 top-incrementor) (cache-current-module! 0 top-incrementor)
(load-static-procedure 0 top-incrementor) (load-static-procedure 0 top-incrementor)
(return 0) (return 0)
@ -217,7 +217,7 @@
(begin-program top-incrementor (begin-program top-incrementor
((name . top-incrementor))) ((name . top-incrementor)))
(assert-nargs-ee/locals 0 1) (standard-prelude 0 1 #f)
(cached-toplevel-ref 0 top-incrementor *top-val*) (cached-toplevel-ref 0 top-incrementor *top-val*)
(add1 0 0) (add1 0 0)
(cached-toplevel-set! 0 top-incrementor *top-val*) (cached-toplevel-set! 0 top-incrementor *top-val*)
@ -232,14 +232,14 @@
(assemble-program (assemble-program
'((begin-program get-sqrt-trampoline '((begin-program get-sqrt-trampoline
((name . get-sqrt-trampoline))) ((name . get-sqrt-trampoline)))
(assert-nargs-ee/locals 0 1) (standard-prelude 0 1 #f)
(load-static-procedure 0 sqrt-trampoline) (load-static-procedure 0 sqrt-trampoline)
(return 0) (return 0)
(end-program) (end-program)
(begin-program sqrt-trampoline (begin-program sqrt-trampoline
((name . sqrt-trampoline))) ((name . sqrt-trampoline)))
(assert-nargs-ee/locals 1 1) (standard-prelude 1 2 #f)
(cached-module-ref 1 (guile) #t sqrt) (cached-module-ref 1 (guile) #t sqrt)
(tail-call 1 1) (tail-call 1 1)
(end-program))))) (end-program)))))
@ -252,14 +252,14 @@
(assemble-program (assemble-program
'((begin-program make-top-incrementor '((begin-program make-top-incrementor
((name . make-top-incrementor))) ((name . make-top-incrementor)))
(assert-nargs-ee/locals 0 1) (standard-prelude 0 1 #f)
(load-static-procedure 0 top-incrementor) (load-static-procedure 0 top-incrementor)
(return 0) (return 0)
(end-program) (end-program)
(begin-program top-incrementor (begin-program top-incrementor
((name . 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*) (cached-module-ref 0 (tests rtl) #f *top-val*)
(add1 0 0) (add1 0 0)
(cached-module-set! 0 (tests rtl) #f *top-val*) (cached-module-set! 0 (tests rtl) #f *top-val*)
@ -271,7 +271,7 @@
(with-test-prefix "debug contexts" (with-test-prefix "debug contexts"
(let ((return-3 (assemble-program (let ((return-3 (assemble-program
'((begin-program return-3 ((name . return-3))) '((begin-program return-3 ((name . return-3)))
(assert-nargs-ee/locals 0 1) (standard-prelude 0 1 #f)
(load-constant 0 3) (load-constant 0 3)
(return 0) (return 0)
(end-program))))) (end-program)))))
@ -292,7 +292,7 @@
(procedure-name (procedure-name
(assemble-program (assemble-program
'((begin-program foo ((name . foo))) '((begin-program foo ((name . foo)))
(assert-nargs-ee/locals 0 1) (standard-prelude 0 1 #f)
(load-constant 0 42) (load-constant 0 42)
(return 0) (return 0)
(end-program)))))) (end-program))))))