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