[bpt/guile.git] / test-suite / tests / rtl.test

;;;; Low-level tests of the RTL assembler -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; 	Copyright (C) 2010, 2011, 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 as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (tests rtl)
  #:use-module (test-suite lib)
  #:use-module (system vm assembler))

(define-syntax-rule (assert-equal val expr)
  (let ((x val))
    (pass-if (object->string x) (equal? expr x))))

(define (return-constant val)
  (assemble-program `((begin-program foo)
                      (assert-nargs-ee/locals 0 1)
                      (load-constant 0 ,val)
                      (return 0)
                      (end-program))))

(define-syntax-rule (assert-constants val ...)
  (begin
    (assert-equal val ((return-constant val)))
    ...))

(with-test-prefix "load-constant"
  (assert-constants
   1
   -1
   0
   most-positive-fixnum
   most-negative-fixnum
   #t
   #\c
   (integer->char 16000)
   3.14
   "foo"
   'foo
   #:foo
   "æ" ;; a non-ASCII Latin-1 string
   "λ" ;; non-ascii, non-latin-1
   '(1 . 2)
   '(1 2 3 4)
   #(1 2 3)
   #("foo" "bar" 'baz)
   ;; FIXME: Add tests for arrays (uniform and otherwise)
   ))

(with-test-prefix "static procedure"
  (assert-equal 42
                (((assemble-program `((begin-program foo)
                                      (assert-nargs-ee/locals 0 1)
                                      (load-static-procedure 0 bar)
                                      (return 0)
                                      (end-program)
                                      (begin-program bar)
                                      (assert-nargs-ee/locals 0 1)
                                      (load-constant 0 42)
                                      (return 0)
                                      (end-program)))))))

(with-test-prefix "loop"
  (assert-equal (* 999 500)
                (let ((sumto
                       (assemble-program
                        ;; 0: limit
                        ;; 1: n
                        ;; 2: accum
                        '((begin-program countdown)
                          (assert-nargs-ee/locals 1 2)
                          (br fix-body)
                          (label loop-head)
                          (br-if-= 1 0 out)
                          (add 2 1 2)
                          (add1 1 1)
                          (br loop-head)
                          (label fix-body)
                          (load-constant 1 0)
                          (load-constant 2 0)
                          (br loop-head)
                          (label out)
                          (return 2)
                          (end-program)))))
                  (sumto 1000))))

(with-test-prefix "accum"
  (assert-equal (+ 1 2 3)
                (let ((make-accum
                       (assemble-program
                        ;; 0: elt
                        ;; 1: tail
                        ;; 2: head
                        '((begin-program 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)
                          (assert-nargs-ee/locals 1 2)
                          (free-ref 1 0)
                          (box-ref 2 1)
                          (add 2 2 0)
                          (box-set! 1 2)
                          (return 2)
                          (end-program)))))
                  (let ((accum (make-accum)))
                    (accum 1)
                    (accum 2)
                    (accum 3)))))

(with-test-prefix "call"
  (assert-equal 42
                (let ((call ;; (lambda (x) (x))
                       (assemble-program
                        '((begin-program call)
                          (assert-nargs-ee/locals 1 0)
                          (call 1 0 ())
                          (return 1) ;; MVRA from call
                          (return 1) ;; RA from call
                          (end-program)))))
                  (call (lambda () 42))))

  (assert-equal 6
                (let ((call-with-3 ;; (lambda (x) (x 3))
                       (assemble-program
                        '((begin-program call-with-3)
                          (assert-nargs-ee/locals 1 1)
                          (load-constant 1 3)
                          (call 2 0 (1))
                          (return 2) ;; MVRA from call
                          (return 2) ;; RA from call
                          (end-program)))))
                  (call-with-3 (lambda (x) (* x 2))))))

(with-test-prefix "tail-call"
  (assert-equal 3
                (let ((call ;; (lambda (x) (x))
                       (assemble-program
                        '((begin-program call)
                          (assert-nargs-ee/locals 1 0)
                          (tail-call 0 0)
                          (end-program)))))
                  (call (lambda () 3))))

  (assert-equal 6
                (let ((call-with-3 ;; (lambda (x) (x 3))
                       (assemble-program
                        '((begin-program call-with-3)
                          (assert-nargs-ee/locals 1 1)
                          (mov 1 0) ;; R1 <- R0
                          (load-constant 0 3) ;; R0 <- 3
                          (tail-call 1 1)
                          (end-program)))))
                  (call-with-3 (lambda (x) (* x 2))))))

(with-test-prefix "cached-toplevel-ref"
  (assert-equal 5.0
                (let ((get-sqrt-trampoline
                       (assemble-program
                        '((begin-program 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)
                          (assert-nargs-ee/locals 1 1)
                          (cached-toplevel-ref 1 sqrt-scope sqrt)
                          (tail-call 1 1)
                          (end-program)))))
                  ((get-sqrt-trampoline) 25.0))))

(define *top-val* 0)

(with-test-prefix "cached-toplevel-set!"
  (let ((prev *top-val*))
    (assert-equal (1+ prev)
                  (let ((make-top-incrementor
                         (assemble-program
                          '((begin-program 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)
                            (assert-nargs-ee/locals 0 1)
                            (cached-toplevel-ref 0 top-incrementor *top-val*)
                            (add1 0 0)
                            (cached-toplevel-set! 0 top-incrementor *top-val*)
                            (return/values 0)
                            (end-program)))))
                    ((make-top-incrementor))
                    *top-val*))))

(with-test-prefix "cached-module-ref"
  (assert-equal 5.0
                (let ((get-sqrt-trampoline
                       (assemble-program
                        '((begin-program get-sqrt-trampoline)
                          (assert-nargs-ee/locals 0 1)
                          (load-static-procedure 0 sqrt-trampoline)
                          (return 0)
                          (end-program)

                          (begin-program sqrt-trampoline)
                          (assert-nargs-ee/locals 1 1)
                          (cached-module-ref 1 (guile) #t sqrt)
                          (tail-call 1 1)
                          (end-program)))))
                  ((get-sqrt-trampoline) 25.0))))

(with-test-prefix "cached-module-set!"
  (let ((prev *top-val*))
    (assert-equal (1+ prev)
                  (let ((make-top-incrementor
                         (assemble-program
                          '((begin-program make-top-incrementor)
                            (assert-nargs-ee/locals 0 1)
                            (load-static-procedure 0 top-incrementor)
                            (return 0)
                            (end-program)

                            (begin-program top-incrementor)
                            (assert-nargs-ee/locals 0 1)
                            (cached-module-ref 0 (tests rtl) #f *top-val*)
                            (add1 0 0)
                            (cached-module-set! 0 (tests rtl) #f *top-val*)
                            (return 0)
                            (end-program)))))
                    ((make-top-incrementor))
                    *top-val*))))
Commit	Line	Data
e78991aa AW	1	;;;; Low-level tests of the RTL assembler -- mode: scheme; coding: utf-8; --
	2	;;;;
	3	;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
	4	;;;;
	5	;;;; This library is free software; you can redistribute it and/or
	6	;;;; modify it under the terms of the GNU Lesser General Public
	7	;;;; License as published by the Free Software Foundation; either
	8	;;;; version 3 of the License, or (at your option) any later version.
	9	;;;;
	10	;;;; This library is distributed in the hope that it will be useful,
	11	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	;;;; Lesser General Public License for more details.
	14	;;;;
	15	;;;; You should have received a copy of the GNU Lesser General Public
	16	;;;; License along with this library; if not, write to the Free Software
	17	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
	18
	19	(define-module (tests rtl)
	20	#:use-module (test-suite lib)
	21	#:use-module (system vm assembler))
	22
	23	(define-syntax-rule (assert-equal val expr)
	24	(let ((x val))
	25	(pass-if (object->string x) (equal? expr x))))
	26
	27	(define (return-constant val)
	28	(assemble-program `((begin-program foo)
	29	(assert-nargs-ee/locals 0 1)
	30	(load-constant 0 ,val)
	31	(return 0)
	32	(end-program))))
	33
	34	(define-syntax-rule (assert-constants val ...)
	35	(begin
	36	(assert-equal val ((return-constant val)))
	37	...))
	38
	39	(with-test-prefix "load-constant"
	40	(assert-constants
	41	1
	42	-1
	43	0
	44	most-positive-fixnum
	45	most-negative-fixnum
	46	#t
	47	#\c
	48	(integer->char 16000)
	49	3.14
	50	"foo"
	51	'foo
	52	#:foo
	53	"æ" ;; a non-ASCII Latin-1 string
	54	"λ" ;; non-ascii, non-latin-1
	55	'(1 . 2)
	56	'(1 2 3 4)
	57	#(1 2 3)
	58	#("foo" "bar" 'baz)
	59	;; FIXME: Add tests for arrays (uniform and otherwise)
	60	))
	61
	62	(with-test-prefix "static procedure"
	63	(assert-equal 42
	64	(((assemble-program `((begin-program foo)
65	(assert-nargs-ee/locals 0 1)
66	(load-static-procedure 0 bar)
67	(return 0)
68	(end-program)
69	(begin-program bar)
70	(assert-nargs-ee/locals 0 1)
71	(load-constant 0 42)
72	(return 0)
73	(end-program)))))))
74
75	(with-test-prefix "loop"
76	(assert-equal (* 999 500)
77	(let ((sumto
78	(assemble-program
79	;; 0: limit
80	;; 1: n
81	;; 2: accum
82	'((begin-program countdown)
83	(assert-nargs-ee/locals 1 2)
84	(br fix-body)
85	(label loop-head)
86	(br-if-= 1 0 out)
87	(add 2 1 2)
88	(add1 1 1)
89	(br loop-head)
90	(label fix-body)
91	(load-constant 1 0)
92	(load-constant 2 0)
93	(br loop-head)
94	(label out)
95	(return 2)
96	(end-program)))))
97	(sumto 1000))))
98
99	(with-test-prefix "accum"
100	(assert-equal (+ 1 2 3)
101	(let ((make-accum
102	(assemble-program
103	;; 0: elt
104	;; 1: tail
105	;; 2: head
106	'((begin-program make-accum)
107	(assert-nargs-ee/locals 0 2)
108	(load-constant 0 0)
109	(box 0 0)
110	(make-closure 1 accum (0))
111	(return 1)
112	(end-program)
113	(begin-program accum)
114	(assert-nargs-ee/locals 1 2)
115	(free-ref 1 0)
116	(box-ref 2 1)
117	(add 2 2 0)
118	(box-set! 1 2)
119	(return 2)
120	(end-program)))))
121	(let ((accum (make-accum)))
122	(accum 1)
123	(accum 2)
124	(accum 3)))))
125
126	(with-test-prefix "call"
127	(assert-equal 42
128	(let ((call ;; (lambda (x) (x))
129	(assemble-program
130	'((begin-program call)
131	(assert-nargs-ee/locals 1 0)
132	(call 1 0 ())
133	(return 1) ;; MVRA from call
134	(return 1) ;; RA from call
135	(end-program)))))
136	(call (lambda () 42))))
137
138	(assert-equal 6
139	(let ((call-with-3 ;; (lambda (x) (x 3))
140	(assemble-program
141	'((begin-program call-with-3)
142	(assert-nargs-ee/locals 1 1)
143	(load-constant 1 3)
144	(call 2 0 (1))
145	(return 2) ;; MVRA from call
146	(return 2) ;; RA from call
147	(end-program)))))
148	(call-with-3 (lambda (x) (* x 2))))))
149
150	(with-test-prefix "tail-call"
151	(assert-equal 3
152	(let ((call ;; (lambda (x) (x))
153	(assemble-program
154	'((begin-program call)
155	(assert-nargs-ee/locals 1 0)
156	(tail-call 0 0)
157	(end-program)))))
158	(call (lambda () 3))))
159
160	(assert-equal 6
161	(let ((call-with-3 ;; (lambda (x) (x 3))
162	(assemble-program
163	'((begin-program call-with-3)
164	(assert-nargs-ee/locals 1 1)
165	(mov 1 0) ;; R1 <- R0
166	(load-constant 0 3) ;; R0 <- 3
167	(tail-call 1 1)
168	(end-program)))))
169	(call-with-3 (lambda (x) (* x 2))))))
170
171	(with-test-prefix "cached-toplevel-ref"
172	(assert-equal 5.0
173	(let ((get-sqrt-trampoline
174	(assemble-program
175	'((begin-program get-sqrt-trampoline)
176	(assert-nargs-ee/locals 0 1)
177	(cache-current-module! 0 sqrt-scope)
178	(load-static-procedure 0 sqrt-trampoline)
179	(return 0)
180	(end-program)
181
182	(begin-program sqrt-trampoline)
183	(assert-nargs-ee/locals 1 1)
184	(cached-toplevel-ref 1 sqrt-scope sqrt)
185	(tail-call 1 1)
186	(end-program)))))
187	((get-sqrt-trampoline) 25.0))))
188
189	(define top-val 0)
190
191	(with-test-prefix "cached-toplevel-set!"
192	(let ((prev top-val))
193	(assert-equal (1+ prev)
194	(let ((make-top-incrementor
195	(assemble-program
196	'((begin-program make-top-incrementor)
197	(assert-nargs-ee/locals 0 1)
198	(cache-current-module! 0 top-incrementor)
199	(load-static-procedure 0 top-incrementor)
200	(return 0)
201	(end-program)
202
203	(begin-program top-incrementor)
204	(assert-nargs-ee/locals 0 1)
205	(cached-toplevel-ref 0 top-incrementor top-val)
206	(add1 0 0)
207	(cached-toplevel-set! 0 top-incrementor top-val)
208	(return/values 0)
209	(end-program)))))
210	((make-top-incrementor))
211	top-val))))
212
213	(with-test-prefix "cached-module-ref"
214	(assert-equal 5.0
215	(let ((get-sqrt-trampoline
216	(assemble-program
217	'((begin-program get-sqrt-trampoline)
218	(assert-nargs-ee/locals 0 1)
219	(load-static-procedure 0 sqrt-trampoline)
220	(return 0)
221	(end-program)
222
223	(begin-program sqrt-trampoline)
224	(assert-nargs-ee/locals 1 1)
225	(cached-module-ref 1 (guile) #t sqrt)
226	(tail-call 1 1)
227	(end-program)))))
228	((get-sqrt-trampoline) 25.0))))
229
230	(with-test-prefix "cached-module-set!"
231	(let ((prev top-val))
232	(assert-equal (1+ prev)
233	(let ((make-top-incrementor
234	(assemble-program
235	'((begin-program make-top-incrementor)
236	(assert-nargs-ee/locals 0 1)
237	(load-static-procedure 0 top-incrementor)
238	(return 0)
239	(end-program)
240
241	(begin-program top-incrementor)
242	(assert-nargs-ee/locals 0 1)
243	(cached-module-ref 0 (tests rtl) #f top-val)
244	(add1 0 0)
245	(cached-module-set! 0 (tests rtl) #f top-val)
246	(return 0)
247	(end-program)))))
248	((make-top-incrementor))
249	top-val))))