1;;;; Low-level tests of the bytecode assembler -*- mode: scheme; coding: utf-8; -*-
2;;;;
3;;;; 	Copyright (C) 2010, 2011, 2012, 2013, 2014, 2015 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 bytecode)
20  #:use-module (test-suite lib)
21  #:use-module (system vm assembler)
22  #:use-module (system vm program)
23  #:use-module (system vm loader)
24  #:use-module (system vm linker)
25  #:use-module (system vm debug))
26
27(define (assemble-program instructions)
28  "Take the sequence of instructions @var{instructions}, assemble them
29into bytecode, link an image, and load that image from memory.  Returns
30a procedure."
31  (let ((asm (make-assembler)))
32    (emit-text asm instructions)
33    (load-thunk-from-memory (link-assembly asm #:page-aligned? #f))))
34
35(define-syntax-rule (assert-equal val expr)
36  (let ((x val))
37    (pass-if (object->string x) (equal? expr x))))
38
39(define (return-constant val)
40  (assemble-program `((begin-program foo
41                                     ((name . foo)))
42                      (begin-standard-arity () 2 #f)
43                      (load-constant 0 ,val)
44                      (return-values 2)
45                      (end-arity)
46                      (end-program))))
47
48(define-syntax-rule (assert-constants val ...)
49  (begin
50    (assert-equal val ((return-constant val)))
51    ...))
52
53(with-test-prefix "load-constant"
54  (assert-constants
55   1
56   -1
57   0
58   most-positive-fixnum
59   most-negative-fixnum
60   #t
61   #\c
62   (integer->char 16000)
63   3.14
64   "foo"
65   'foo
66   #:foo
67   "æ" ;; a non-ASCII Latin-1 string
68   "λ" ;; non-ascii, non-latin-1
69   '(1 . 2)
70   '(1 2 3 4)
71   #(1 2 3)
72   #("foo" "bar" 'baz)
73   #vu8()
74   #vu8(1 2 3 4 128 129 130)
75   #u32()
76   #u32(1 2 3 4 128 129 130 255 1000)
77   ;; FIXME: Add more tests for arrays (uniform and otherwise)
78   ))
79
80(define-syntax-rule (assert-bad-constants val ...)
81  (begin
82    (pass-if-exception (object->string val) exception:miscellaneous-error
83      (return-constant val))
84    ...))
85
86(with-test-prefix "bad constants"
87  (assert-bad-constants (make-symbol "foo")
88                        (lambda () 100)))
89
90(with-test-prefix "static procedure"
91  (assert-equal 42
92                (((assemble-program `((begin-program foo
93                                                     ((name . foo)))
94                                      (begin-standard-arity () 2 #f)
95                                      (load-static-procedure 0 bar)
96                                      (return-values 2)
97                                      (end-arity)
98                                      (end-program)
99                                      (begin-program bar
100                                                     ((name . bar)))
101                                      (begin-standard-arity () 2 #f)
102                                      (load-constant 0 42)
103                                      (return-values 2)
104                                      (end-arity)
105                                      (end-program)))))))
106
107(with-test-prefix "loop"
108  (assert-equal (* 999 500)
109                (let ((sumto
110                       (assemble-program
111                        ;; 0: limit
112                        ;; 1: n
113                        ;; 2: accum
114                        '((begin-program countdown
115                                         ((name . countdown)))
116                          (begin-standard-arity (x) 4 #f)
117                          (definition closure 0 scm)
118                          (definition x 1 scm)
119                          (br fix-body)
120                          (label loop-head)
121                          (br-if-= 1 2 #f out)
122                          (add 0 1 0)
123                          (add/immediate 1 1 1)
124                          (br loop-head)
125                          (label fix-body)
126                          (load-constant 1 0)
127                          (load-constant 0 0)
128                          (br loop-head)
129                          (label out)
130                          (mov 2 0)
131                          (return-values 2)
132                          (end-arity)
133                          (end-program)))))
134                  (sumto 1000))))
135
136(with-test-prefix "accum"
137  (assert-equal (+ 1 2 3)
138                (let ((make-accum
139                       (assemble-program
140                        ;; 0: elt
141                        ;; 1: tail
142                        ;; 2: head
143                        '((begin-program make-accum
144                                         ((name . make-accum)))
145                          (begin-standard-arity () 3 #f)
146                          (load-constant 1 0)
147                          (box 1 1)
148                          (make-closure 0 accum 1)
149                          (free-set! 0 1 0)
150                          (mov 1 0)
151                          (return-values 2)
152                          (end-arity)
153                          (end-program)
154                          (begin-program accum
155                                         ((name . accum)))
156                          (begin-standard-arity (x) 4 #f)
157                          (definition closure 0 scm)
158                          (definition x 1 scm)
159                          (free-ref 1 3 0)
160                          (box-ref 0 1)
161                          (add 0 0 2)
162                          (box-set! 1 0)
163                          (mov 2 0)
164                          (return-values 2)
165                          (end-arity)
166                          (end-program)))))
167                  (let ((accum (make-accum)))
168                    (accum 1)
169                    (accum 2)
170                    (accum 3)))))
171
172(with-test-prefix "call"
173  (assert-equal 42
174                (let ((call ;; (lambda (x) (x))
175                       (assemble-program
176                        '((begin-program call
177                                         ((name . call)))
178                          (begin-standard-arity (f) 7 #f)
179                          (definition closure 0 scm)
180                          (definition f 1 scm)
181                          (mov 1 5)
182                          (call 5 1)
183                          (receive 1 5 7)
184                          (return-values 2)
185                          (end-arity)
186                          (end-program)))))
187                  (call (lambda () 42))))
188
189  (assert-equal 6
190                (let ((call-with-3 ;; (lambda (x) (x 3))
191                       (assemble-program
192                        '((begin-program call-with-3
193                                         ((name . call-with-3)))
194                          (begin-standard-arity (f) 7 #f)
195                          (definition closure 0 scm)
196                          (definition f 1 scm)
197                          (mov 1 5)
198                          (load-constant 0 3)
199                          (call 5 2)
200                          (receive 1 5 7)
201                          (return-values 2)
202                          (end-arity)
203                          (end-program)))))
204                  (call-with-3 (lambda (x) (* x 2))))))
205
206(with-test-prefix "tail-call"
207  (assert-equal 3
208                (let ((call ;; (lambda (x) (x))
209                       (assemble-program
210                        '((begin-program call
211                                         ((name . call)))
212                          (begin-standard-arity (f) 2 #f)
213                          (definition closure 0 scm)
214                          (definition f 1 scm)
215                          (mov 1 0)
216                          (tail-call 1)
217                          (end-arity)
218                          (end-program)))))
219                  (call (lambda () 3))))
220
221  (assert-equal 6
222                (let ((call-with-3 ;; (lambda (x) (x 3))
223                       (assemble-program
224                        '((begin-program call-with-3
225                                         ((name . call-with-3)))
226                          (begin-standard-arity (f) 2 #f)
227                          (definition closure 0 scm)
228                          (definition f 1 scm)
229                          (mov 1 0) ;; R0 <- R1
230                          (load-constant 0 3) ;; R1 <- 3
231                          (tail-call 2)
232                          (end-arity)
233                          (end-program)))))
234                  (call-with-3 (lambda (x) (* x 2))))))
235
236(with-test-prefix "cached-toplevel-ref"
237  (assert-equal 5.0
238                (let ((get-sqrt-trampoline
239                       (assemble-program
240                        '((begin-program get-sqrt-trampoline
241                                         ((name . get-sqrt-trampoline)))
242                          (begin-standard-arity () 2 #f)
243                          (current-module 0)
244                          (cache-current-module! 0 sqrt-scope)
245                          (load-static-procedure 0 sqrt-trampoline)
246                          (return-values 2)
247                          (end-arity)
248                          (end-program)
249
250                          (begin-program sqrt-trampoline
251                                         ((name . sqrt-trampoline)))
252                          (begin-standard-arity (x) 3 #f)
253                          (definition closure 0 scm)
254                          (definition x 1 scm)
255                          (cached-toplevel-box 0 sqrt-scope sqrt #t)
256                          (box-ref 2 0)
257                          (tail-call 2)
258                          (end-arity)
259                          (end-program)))))
260                  ((get-sqrt-trampoline) 25.0))))
261
262(define *top-val* 0)
263
264(with-test-prefix "cached-toplevel-set!"
265  (let ((prev *top-val*))
266    (assert-equal (1+ prev)
267                  (let ((make-top-incrementor
268                         (assemble-program
269                          '((begin-program make-top-incrementor
270                                           ((name . make-top-incrementor)))
271                            (begin-standard-arity () 2 #f)
272                            (current-module 0)
273                            (cache-current-module! 0 top-incrementor)
274                            (load-static-procedure 0 top-incrementor)
275                            (return-values 2)
276                            (end-arity)
277                            (end-program)
278
279                            (begin-program top-incrementor
280                                           ((name . top-incrementor)))
281                            (begin-standard-arity () 3 #f)
282                            (cached-toplevel-box 1 top-incrementor *top-val* #t)
283                            (box-ref 0 1)
284                            (add/immediate 0 0 1)
285                            (box-set! 1 0)
286                            (return-values 1)
287                            (end-arity)
288                            (end-program)))))
289                    ((make-top-incrementor))
290                    *top-val*))))
291
292(with-test-prefix "cached-module-ref"
293  (assert-equal 5.0
294                (let ((get-sqrt-trampoline
295                       (assemble-program
296                        '((begin-program get-sqrt-trampoline
297                                         ((name . get-sqrt-trampoline)))
298                          (begin-standard-arity () 2 #f)
299                          (load-static-procedure 0 sqrt-trampoline)
300                          (return-values 2)
301                          (end-arity)
302                          (end-program)
303
304                          (begin-program sqrt-trampoline
305                                         ((name . sqrt-trampoline)))
306                          (begin-standard-arity (x) 3 #f)
307                          (definition closure 0 scm)
308                          (definition x 1 scm)
309                          (cached-module-box 0 (guile) sqrt #t #t)
310                          (box-ref 2 0)
311                          (tail-call 2)
312                          (end-arity)
313                          (end-program)))))
314                  ((get-sqrt-trampoline) 25.0))))
315
316(with-test-prefix "cached-module-set!"
317  (let ((prev *top-val*))
318    (assert-equal (1+ prev)
319                  (let ((make-top-incrementor
320                         (assemble-program
321                          '((begin-program make-top-incrementor
322                                           ((name . make-top-incrementor)))
323                            (begin-standard-arity () 2 #f)
324                            (load-static-procedure 0 top-incrementor)
325                            (return-values 2)
326                            (end-arity)
327                            (end-program)
328
329                            (begin-program top-incrementor
330                                           ((name . top-incrementor)))
331                            (begin-standard-arity () 3 #f)
332                            (cached-module-box 1 (tests bytecode) *top-val* #f #t)
333                            (box-ref 0 1)
334                            (add/immediate 0 0 1)
335                            (box-set! 1 0)
336                            (mov 1 0)
337                            (return-values 2)
338                            (end-arity)
339                            (end-program)))))
340                    ((make-top-incrementor))
341                    *top-val*))))
342
343(with-test-prefix "debug contexts"
344  (let ((return-3 (assemble-program
345                   '((begin-program return-3 ((name . return-3)))
346                     (begin-standard-arity () 2 #f)
347                     (load-constant 0 3)
348                     (return-values 2)
349                     (end-arity)
350                     (end-program)))))
351    (pass-if "program name"
352      (and=> (find-program-debug-info (program-code return-3))
353             (lambda (pdi)
354               (equal? (program-debug-info-name pdi)
355                       'return-3))))
356
357    (pass-if "program address"
358      (and=> (find-program-debug-info (program-code return-3))
359             (lambda (pdi)
360               (equal? (program-debug-info-addr pdi)
361                       (program-code return-3)))))))
362
363(with-test-prefix "procedure name"
364  (pass-if-equal 'foo
365      (procedure-name
366       (assemble-program
367        '((begin-program foo ((name . foo)))
368          (begin-standard-arity () 2 #f)
369          (load-constant 0 42)
370          (return-values 2)
371          (end-arity)
372          (end-program))))))
373
374(with-test-prefix "simple procedure arity"
375  (pass-if-equal "#<procedure foo ()>"
376      (object->string
377       (assemble-program
378        '((begin-program foo ((name . foo)))
379          (begin-standard-arity () 2 #f)
380          (definition closure 0 scm)
381          (load-constant 0 42)
382          (return-values 2)
383          (end-arity)
384          (end-program)))))
385  (pass-if-equal "#<procedure foo (x y)>"
386      (object->string
387       (assemble-program
388        '((begin-program foo ((name . foo)))
389          (begin-standard-arity (x y) 3 #f)
390          (definition closure 0 scm)
391          (definition x 1 scm)
392          (definition y 2 scm)
393          (load-constant 1 42)
394          (return-values 2)
395          (end-arity)
396          (end-program)))))
397
398  (pass-if-equal "#<procedure foo (x #:optional y . z)>"
399      (object->string
400       (assemble-program
401        '((begin-program foo ((name . foo)))
402          (begin-opt-arity (x) (y) z 4 #f)
403          (definition closure 0 scm)
404          (definition x 1 scm)
405          (definition y 2 scm)
406          (definition z 3 scm)
407          (load-constant 2 42)
408          (return-values 2)
409          (end-arity)
410          (end-program))))))
411
412(with-test-prefix "procedure docstrings"
413  (pass-if-equal "qux qux"
414      (procedure-documentation
415       (assemble-program
416        '((begin-program foo ((name . foo) (documentation . "qux qux")))
417          (begin-standard-arity () 2 #f)
418          (load-constant 0 42)
419          (return-values 2)
420          (end-arity)
421          (end-program))))))
422
423(with-test-prefix "procedure properties"
424  ;; No properties.
425  (pass-if-equal '()
426      (procedure-properties
427       (assemble-program
428        '((begin-program foo ())
429          (begin-standard-arity () 2 #f)
430          (load-constant 0 42)
431          (return-values 2)
432          (end-arity)
433          (end-program)))))
434
435  ;; Name and docstring (which actually don't go out to procprops).
436  (pass-if-equal '((name . foo)
437                   (documentation . "qux qux"))
438      (procedure-properties
439       (assemble-program
440        '((begin-program foo ((name . foo) (documentation . "qux qux")))
441          (begin-standard-arity () 2 #f)
442          (load-constant 0 42)
443          (return-values 2)
444          (end-arity)
445          (end-program)))))
446
447  ;; A property that actually needs serialization.
448  (pass-if-equal '((name . foo)
449                   (documentation . "qux qux")
450                   (moo . "mooooooooooooo"))
451      (procedure-properties
452       (assemble-program
453        '((begin-program foo ((name . foo)
454                              (documentation . "qux qux")
455                              (moo . "mooooooooooooo")))
456          (begin-standard-arity () 2 #f)
457          (load-constant 0 42)
458          (return-values 2)
459          (end-arity)
460          (end-program)))))
461
462  ;; Procedure-name still works in this case.
463  (pass-if-equal 'foo
464      (procedure-name
465       (assemble-program
466        '((begin-program foo ((name . foo)
467                              (documentation . "qux qux")
468                              (moo . "mooooooooooooo")))
469          (begin-standard-arity () 2 #f)
470          (load-constant 0 42)
471          (return-values 2)
472          (end-arity)
473          (end-program))))))
474