1;;; misc.ms 2;;; Copyright 1984-2017 Cisco Systems, Inc. 3;;; 4;;; Licensed under the Apache License, Version 2.0 (the "License"); 5;;; you may not use this file except in compliance with the License. 6;;; You may obtain a copy of the License at 7;;; 8;;; http://www.apache.org/licenses/LICENSE-2.0 9;;; 10;;; Unless required by applicable law or agreed to in writing, software 11;;; distributed under the License is distributed on an "AS IS" BASIS, 12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13;;; See the License for the specific language governing permissions and 14;;; limitations under the License. 15 16;;; regression and other tests that don't fit somewhere more logical 17 18(define-syntax biglet 19 (lambda (x) 20 (syntax-case x () 21 ((_ n bindings e) 22 (let ((nv (datum n))) 23 (if (= nv 0) 24 (syntax (let bindings e)) 25 (with-syntax ((m (- nv 1))) 26 (syntax (biglet m ((g n) . bindings) (+ g e)))))))))) 27 28(define-syntax biglambda 29 (lambda (x) 30 (syntax-case x () 31 ((_ n vars e) 32 (let ((nv (datum n))) 33 (if (= nv 0) 34 (syntax (lambda vars e)) 35 (with-syntax ((m (- nv 1))) 36 (syntax (biglambda m (g . vars) (+ g e)))))))))) 37 38(mat cycle 39 (let ((x '#1=(a b . #1#))) 40 (eqv? x x)) 41 (let-syntax ((a (lambda (y) 42 (let ((x (list 'quote '*))) 43 (set-car! (cdr x) x) 44 (datum->syntax (syntax a) x))))) 45 (let ((a (a))) (and (pair? a) (eq? (cadr a) a)))) 46 (let-syntax ((a (lambda (y) 47 (let ((x (list 1 '*))) 48 (set-car! (cdr x) x) 49 (with-syntax ((l (datum->syntax (syntax a) x))) 50 (syntax (quote l))))))) 51 (let ((a (a))) (and (pair? a) (eq? (car a) 1) (eq? (cadr a) a)))) 52; (let ((x '(#2=(#2#) . #2#))) 53; (and (eq? (car x) (caar x)) (eq? (car x) (cdr x)))) 54) 55 56(mat overflow ; attempt to force dooverflow, dooverflood, apply_dooverflood 57 ;; this should test dooverflow 58 (eqv? (let f ((n 100000)) 59 (if (= n 0) 60 0 61 (+ (f (- n 1)) 1))) 62 100000) 63 ;; this should test dooverflow 64 (eqv? (let f ((n 10000) (m 0)) 65 (if (= n 0) 66 m 67 (f (call/cc (lambda (k) (- n 1))) 68 (call/cc (lambda (k) (+ (k (+ m 1)) 1)))))) 69 10000) 70 ;; this should test dooverflood 71 (eqv? (let f ((n 10000)) 72 (if (= n 0) 73 0 74 (let ((m (biglet 100 () 0))) 75 (+ m (f (- n 1)))))) 76 (* 10000 (let f ((n 100) (m 0)) (if (= n 0) m (f (- n 1) (+ m n)))))) 77 ;; this should test apply_dooverflood 78 (= (length (apply list (make-list 100000))) 100000) 79 ;; this should test apply_dooverflood 80 (eqv? (let ((a (biglambda 100 () 0)) 81 (ls (make-list 100 1))) 82 (let f ((n 10000)) 83 (if (= n 0) 84 0 85 (let ((m (apply a ls))) 86 (+ m (f (- n 1))))))) 87 (* 100 10000)) 88 ; this should test overflow w/mrvs 89 (let-syntax ((first (syntax-rules () 90 ((_ e) 91 (call-with-values 92 (lambda () e) 93 (lambda (x . args) x)))))) 94 (eqv? (first (let f ((n 100000)) 95 (if (fx= n 0) 96 (values 1 1) 97 (values (fx+ (first (f (fx- n 1))) 1) 1)))) 98 100001)) 99 ; test overflow w/lots of values to large frame 100 (eqv? (let-syntax ((first (syntax-rules () 101 ((_ e1 e2 ...) 102 (call-with-values 103 (lambda () e1 e2 ...) 104 (lambda (x . args) x)))))) 105 (biglet 100 () (first (apply values (make-list 10000 0))))) 106 5050) 107 (eq? 108 (let () 109 (define foo 110 (lambda () 111 (define-syntax a 112 (lambda (x) 113 (syntax-case x () 114 [(_ n) 115 (with-syntax ([(g ...) (generate-temporaries (make-list (datum n)))]) 116 #'(let ([g 3] ...) (list g ...)))]))) 117 (a 1000))) 118 (define (q n) 119 (call/1cc 120 (lambda (k0) 121 ((call/1cc 122 (lambda (k1) 123 (call/1cc 124 (lambda (k2) 125 (k1 (lambda () (let f ([n n]) (foo) (unless (fx= n 0) (f (- n 1)))) (k2))))) 126 (k0 'done))))))) 127 (q 1000)) 128 'done) 129 ; regression test for np-place-overflow-and-trap treating test part of 130 ; if-expr as tail when if-expr is tail 131 (begin 132 (define $poat-if-bug 133 (lambda (x) 134 (if (or (#3%fx= x 0) ($poat-if-bug (#3%fx- x 1))) 135 'yes 136 'no))) 137 #t) 138 (eq? ($poat-if-bug 20000) 'yes) 139) 140 141(begin 142 (define ls0 '()) 143 (define ls1 '(a)) 144 (define ls2 '(a b)) 145 (define ls3 '(a b c)) 146 (define-syntax relop-length-test 147 (lambda (x) 148 (syntax-case x () 149 [(_ op) 150 (with-syntax (((exp ...) 151 (map (lambda (ls) 152 (with-syntax ((ls ls) 153 ((n ...) '(0 1 2 3 4 5))) 154 #'(list (op (length ls) n) ...))) 155 (list #'ls0 #'ls1 #'ls2 #'ls3)))) 156 (with-syntax ((exp #'(list exp ...))) 157 (with-syntax ((ans (datum->syntax #'* (interpret (datum exp))))) 158 #'(equal? exp 'ans))))])))) 159 160(mat relop-length ; test (relop (length e) n) 161 (eqv? (pretty-print (expand (relop-length-test =))) (void)) 162 (relop-length-test <) 163 (relop-length-test >) 164 (relop-length-test <=) 165 (relop-length-test >=) 166 167 (relop-length-test fx=) 168 (relop-length-test fx<) 169 (relop-length-test fx>) 170 (relop-length-test fx<=) 171 (relop-length-test fx>=) 172) 173 174(mat compiler1 175 (error? ; unbound variable 176 (i-am-not-bound)) 177 (begin 178 (define i-am-bound-but-not-to-a-procedure 'oops) 179 #t) 180 (error? ; non-procedure 181 (i-am-bound-but-not-to-a-procedure)) 182 ;; test cpr1 code to avoid loading closer pointer for direct rec calls 183 ;; make sure closure is loaded for value ref of g 184 (letrec ((g (lambda (x) 185 (if (eq? x 'b) 186 (let ((h g)) (h 'c)) 187 (if (eq? x 'a) 188 (g 'b) 189 'okay))))) 190 (eq? (g 'a) 'okay)) 191 ;; make sure closure is loaded for closure containing g 192 (letrec ((g (lambda (x) 193 (if (eq? x 'b) 194 (let ((h (lambda (x) (g x)))) (h 'c)) 195 (if (eq? x 'a) 196 (g 'b) 197 'okay))))) 198 (eq? (g 'a) 'okay)) 199 ;; test for incorrect call screwing up nocp code 200 (error? (letrec ((g (lambda () (g (list))))) (g))) 201 ;; test for rest list avoidance code being fooled by assignment conversion 202 (begin 203 (define (rest-test x . y) 204 (set! y y) 205 y) 206 (equal? 207 (rest-test 1 2) 208 '(2))) 209 ;; test for bogus conversion of direct lambda calls with rest arguments 210 (equal? ((lambda x x) 1 2 3 4) '(1 2 3 4)) 211 ;; test for register allocator bug 212 (let () 213 (define (foo return) (return 'foo)) 214 (define (goo return) 215 (foo (lambda (y) 216 (let ((x 'goo)) 217 (return x y '() '()))))) 218 (equal? (goo list) '(goo foo () ()))) 219 (let () 220 (define (foo return) (return 'foo)) 221 (define (goo return) 222 (foo (lambda (y) 223 (let ((x 'goo)) 224 (return x y 'hoo '() '()))))) 225 (equal? (goo list) '(goo foo hoo () ()))) 226 (eq? (let ((f (lambda x x))) ((begin 'a f))) '()) 227 (error? (letrec ((a (lambda (v) v))) ((begin 'foo a)))) 228 (equal? (let ((f (case-lambda ((x) 'a) ((x y) 'b) (z z)))) 229 ((begin 'c f) 3 4 5 6)) 230 '(3 4 5 6)) 231 (equal? (let ((f (lambda x x))) 232 (call-with-values (lambda () ((begin 'a f))) list)) 233 '(())) 234 (equal? (let ((f (lambda x x))) 235 (call-with-values (lambda () ((begin 'a f))) 236 (lambda args args))) 237 '(())) 238 (eqv? 239 (let () ; mvlet in 5.0c & before were branching to domvleterr call 240 (define id-var-name 241 (lambda () 242 (define-syntax first 243 (syntax-rules () 244 ((_ e) (#2%call-with-values 245 (lambda () e) 246 (lambda (x . ignore) x))))) 247 (let ((f (lambda () (or (first (values #f 2)) 3)))) 248 (f)))) 249 (id-var-name)) 250 3) 251 (begin (define string->color (lambda (x) (values 1 2))) (procedure? string->color)) 252 (eqv? (call-with-values 253 (lambda () (string->color #f)) 254 (lambda (x y) x)) 255 1) 256 ; test for cp2-store handling of binary dest with singleton next 257 (procedure? 258 (lambda (s end) 259 (let ([end (or (if s end #f) end)]) 260 (if end s #f)))) 261 ; make sure case-lambda clause ordering is observed 262 (equal? 263 (let ((f (case-lambda 264 [(x) (* x x)] 265 [(x y) (+ x x)] 266 [(x . r) (- x x)]))) 267 (list (f 5) (f 5 4) (f 5 4 3))) 268 '(25 10 0)) 269 ; make sure irreducible flow graph doesn't choke the compiler 270 (procedure? 271 (rec q 272 (case-lambda 273 [() (q 0)] 274 [(x) (q)]))) 275 ; regression tests for non-tail-call mref lvalue destination 276 (begin 277 (define (c1-f a) 278 (let ([x (fxvector 0)]) 279 (lambda (v) (fxvector-set! x 0 (modulo v a)) x))) 280 #t) 281 (equal? ((c1-f 7) 10) #vfx(3)) 282 (begin 283 (define (c1-id x) x) 284 (define (c1-g x) (vector-set-fixnum! x 0 (c1-id 17))) 285 #t) 286 (equal? (let ([v (vector 3)]) (c1-g v) v) '#(17)) 287) 288 289(mat compiler2 ; random tests 290 (eqv? (((lambda (x) (lambda (y) (- x y))) 3) 4) -1) 291 (equal? (let ((f (lambda (x) (lambda (y) (- x y))))) 292 (cons ((f 3) 4) ((f 4) 3))) 293 '(-1 . 1)) 294 (eqv? (letrec ((f (lambda (a) a)) 295 (g (lambda (b) (if b (begin (f b) (g (not b))) 17)))) 296 (g #f)) 297 17) 298 (eqv? (letrec ((f (lambda (a) a)) 299 (g (lambda (b) (if b (begin (f b) (g (not b))) 13)))) 300 (g #t)) 301 13) 302 (eqv? (letrec ((f (lambda (a) a)) 303 (g (lambda (b) (if b (begin (f b) (g #f)) 11)))) 304 (g #f)) 305 11) 306 (eqv? (letrec ((f (lambda (a) a)) 307 (g (lambda (b) (if b (begin (f b) (g #f)) 9)))) 308 (g #t)) 309 9) 310 (eqv? (let ((f (lambda (x) (+ x x)))) 311 (let ((g (lambda () f f))) 312 (g) ((g) 3))) 313 6) 314 315 (eqv? (letrec ((f (lambda (x) (+ x x)))) 316 (letrec ((g (lambda () f f))) 317 (g) ((g) 3))) 318 6) 319 (equal? (apply (lambda (x y) (list y x)) 'a 'b '()) '(b a)) 320 (equal? (apply (lambda (x . r) (list r x)) '(a b c)) '((b c) a)) 321 (equal? (apply list '(1 2 3)) '(1 2 3)) 322 (eqv? (apply + '(1 2 3)) 6) 323 (let ([f (lambda x x)]) (equal? (f) '())) 324 (eq? (let () 325 (define *current-gensym* 0) 326 (define (generate-symbol) 327 (set! *current-gensym* (+ *current-gensym* 1)) 328 (string->symbol (number->string *current-gensym*))) 329 (define f (lambda (x) x)) 330 (f 3)) 331 3) 332 (eqv? (let f ((x 0)) (if (= x 0) 1 (* x (f (- x 1))))) 1) 333 (error? (let ((f (lambda () (let ((x 3)) (lambda (y z) (or (= y 3) x)))))) 334 (begin ((f) 3 (+ 'a 3))) 0)) 335 (eqv? (let ((f (lambda () (let ((x 3)) (lambda (y z) (or (= y 3) x)))))) 336 (begin ((f) 3 (+ 3 4)) 0)) 337 0) 338 (let ((f (lambda () (lambda (y z) (or (= y 3) z))))) ((f) 3 (+ 3 4))) 339 (let ((f (lambda () (lambda (y z) (or (= z 7) z))))) ((f) 3 (+ 3 4))) 340 (let ((f (lambda (y z) (or (= y 3) z)))) (f 3 (+ 3 4))) 341 (error? (let ((f (lambda (x) (+ x x)))) (f 3 4))) 342 (error? ; invalid argument count in call to car 343 (cons (car 1 2))) 344 (error? ; invalid argument count in call to cons 345 (let loop () (loop (cons 1 2 3)))) 346 (equal? 347 (call/cc 348 (lambda (k) 349 (cons (k '(a b c))))) 350 '(a b c)) 351 (equal? 352 (call/cc 353 (lambda (k) 354 (let loop () (loop (k '(a b c)))))) 355 '(a b c)) 356 (equal? 357 (call/cc 358 (lambda (k) 359 (letrec ([sum (lambda (n) (if (= n 0) 1 (+ n (sum (- n 1)))))]) 360 (cons (sum (k '(a . b)) 15))))) 361 '(a . b)) 362 (equal? 363 (call/cc 364 (lambda (k) 365 (letrec ([sum (lambda (n) (if (= n 0) 1 (+ n (sum (k '(a . b)) (- n 1)))))]) 366 (cons (sum 15))))) 367 '(a . b)) 368 (equal? 369 (call/cc 370 (lambda (k) 371 (letrec* ([a (lambda () c)] 372 [b (k "hi")] 373 [c (pair? k 1)]) 374 (errorf 'oops "shouldn't reach here ~s" (list a b))))) 375 "hi") 376 ; make sure we set up the stack properly before call-error 377 (or (= (optimize-level) 3) 378 (call/cc 379 (lambda (k) 380 (with-exception-handler 381 (lambda (c) (collect) (k #t)) 382 (rec p (lambda () (('spam 1 2)))))))) 383 ; make sure return-address is set properly and stack is otherwise 384 ; well-formed when we go through call-error for invalid consumer 385 (begin 386 (define ($foo$ x y z w p) w) 387 #t) 388 (or (= (optimize-level) 3) 389 (call/cc 390 (lambda (k) 391 (with-exception-handler (lambda (c) (collect) (k #t)) 392 (lambda () 393 (let ([x (list (lambda () (sort < '(3 2 5 7 9)) (values 1 2 3)))]) 394 ($foo$ 1 2 3 4 5) 395 (call-with-values (car x) x))))))) 396 ; make sure return-address is set properly and stack is otherwise 397 ; well-formed when we go through values-error 398 (begin 399 (define $values (lambda () (printf "hello!\n") (values 1 2 3 4 5 6 7 8))) 400 #t) 401 (or (= (optimize-level) 3) 402 (eqv? 403 (call/cc 404 (lambda (k) 405 (with-exception-handler 406 (lambda (c) (collect) (k 'okay)) 407 (lambda () (if ($values) 3 4))))) 408 'okay)) 409 (or (= (optimize-level) 3) 410 (eqv? 411 (call/cc 412 (lambda (k) 413 (with-exception-handler 414 (lambda (c) (collect) (k 'okay)) 415 (lambda () 416 (let ([x (random 10)]) 417 (if ($values) x 4)))))) 418 'okay)) 419 ; make sure return-address is set properly and stack is otherwise 420 ; well-formed when we go through mvlet-error 421 (or (= (optimize-level) 3) 422 (eqv? 423 (call/cc 424 (lambda (k) 425 (with-exception-handler 426 (lambda (c) (collect) (k 'okay)) 427 (lambda () 428 (let ([x (random 10)]) 429 (call-with-values $values 430 (lambda (x y) 'oops))))))) 431 'okay)) 432 (or (= (optimize-level) 3) 433 (eqv? 434 (call/cc 435 (lambda (k) 436 (with-exception-handler 437 (lambda (c) (collect) (k 'okay)) 438 (lambda () 439 (define f (case-lambda)) 440 (let ([x (random 10)]) 441 (call-with-values $values f)))))) 442 'okay)) 443 (or (= (optimize-level) 3) 444 (eqv? 445 (call/cc 446 (lambda (k) 447 (with-exception-handler 448 (lambda (c) (collect) (k 'okay)) 449 (lambda () 450 (let ([x (random 10)]) 451 (call-with-values 452 (lambda () ($values) (values 1 2 3)) 453 (lambda (x y) 'oops))))))) 454 'okay)) 455 ; make sure compiler doesn't bomb trying to borrow a closure 456 ; whose name isn't already free 457 (equal? 458 (let ([ls '()]) 459 (let ([v (((parameterize ([run-cp0 (lambda (cp0 x) x)]) 460 461 (eval '(lambda (x y) 462 (let ((av (lambda () (x y)))) 463 (av) 464 (lambda () 465 (let ((tt (lambda () (x y)))) 466 (begin (tt) 3))))))) 467 (lambda (z) (set! ls (cons z ls))) 468 17))]) 469 (cons v ls))) 470 '(3 17 17)) 471 ; for good measure, some where borrowing can occur 472 ; tt borrow av 473 (equal? 474 (let ([ls '()]) 475 (let ([v (((parameterize ([run-cp0 (lambda (cp0 x) x)]) 476 (eval '(lambda (x y) 477 (let ((av (lambda () (x y)))) 478 (lambda () 479 (av) 480 (let ((tt (lambda () (x y)))) 481 (begin (tt) 3))))))) 482 (lambda (z) (set! ls (cons z ls))) 483 17))]) 484 (cons v ls))) 485 '(3 17 17)) 486 ; tt borrow av (which happens to be free in tt) 487 (equal? 488 (let ([ls '()]) 489 (let ([v (((parameterize ([run-cp0 (lambda (cp0 x) x)]) 490 491 (eval '(lambda (x y) 492 (let ((av (lambda () (x y)))) 493 (lambda () 494 (let ((tt (lambda () (av) (x y)))) 495 (begin (tt) 3))))))) 496 (lambda (z) (set! ls (cons z ls))) 497 17))]) 498 (cons v ls))) 499 '(3 17 17)) 500 ; tt borrow av, zz borrow av 501 (equal? 502 (let ([ls '()]) 503 (let ([v ((((parameterize ([run-cp0 (lambda (cp0 x) x)]) 504 505 (eval '(lambda (x y) 506 (let ((av (lambda () (x y)))) 507 (lambda () 508 (av) 509 (let ((tt (lambda () (av) (x y)))) 510 (lambda () 511 (tt) 512 (let ([zz (lambda () (x y))]) 513 (begin (zz) 3))))))))) 514 (lambda (z) (set! ls (cons z ls))) 515 17)))]) 516 (cons v ls))) 517 '(3 17 17 17 17)) 518 ; tt borrow av, zz borrow av 519 (equal? 520 (let ([ls '()]) 521 (let ([v ((((parameterize ([run-cp0 (lambda (cp0 x) x)]) 522 (eval '(lambda (x y) 523 (let ((av (lambda () (x y)))) 524 (lambda () 525 (av) 526 (let ((tt (lambda () (av) (x y)))) 527 (lambda () 528 (tt) 529 (let ([zz (lambda () (x y))]) 530 (begin (zz) 3))))))))) 531 (lambda (z) (set! ls (cons z ls))) 532 17)))]) 533 (cons v ls))) 534 '(3 17 17 17 17)) 535 ; zz borrow av (tt goes away) 536 (equal? 537 (let ([ls '()]) 538 (let ([v ((((parameterize ([run-cp0 (lambda (cp0 x) x)]) 539 (eval '(lambda (x y) 540 (let ((av (lambda () (x y)))) 541 (lambda () 542 (av) 543 (let ((tt (lambda () (av) (x y)))) 544 (lambda () 545 (av) 546 (let ([zz (lambda () (x y))]) 547 (begin (zz) 3))))))))) 548 (lambda (z) (set! ls (cons z ls))) 549 17)))]) 550 (cons v ls))) 551 '(3 17 17 17)) 552 ; tt borrow av, zz borrow av 553 (equal? 554 (let ([ls '()]) 555 (let ([v ((((parameterize ([run-cp0 (lambda (cp0 x) x)]) 556 (eval '(lambda (x y) 557 (let ((av (lambda () (x y)))) 558 (lambda () 559 (av) 560 (let ((tt (lambda () (av) (x y)))) 561 (lambda () 562 (tt) 563 (av) 564 (let ([zz (lambda () (x y))]) 565 (begin (zz) 3))))))))) 566 (lambda (z) (set! ls (cons z ls))) 567 17)))]) 568 (cons v ls))) 569 '(3 17 17 17 17 17)) 570 ; tt borrow av, zz borrow av 571 (equal? 572 (let ([ls '()]) 573 (let ([v ((((parameterize ([run-cp0 (lambda (cp0 x) x)]) 574 (eval '(lambda (x y) 575 (let ((av (lambda () (x y)))) 576 (lambda () 577 (av) 578 (let ((tt (lambda () (av) (x y)))) 579 (lambda () 580 (let ([zz (lambda () (tt) (x y))]) 581 (begin (zz) 3))))))))) 582 (lambda (z) (set! ls (cons z ls))) 583 17)))]) 584 (cons v ls))) 585 '(3 17 17 17 17)) 586 ; tt borrow av, zz can't borrow 587 (equal? 588 (let ([ls '()]) 589 (let ([v ((((parameterize ([run-cp0 (lambda (cp0 x) x)]) 590 (eval '(lambda (x y) 591 (let ((av (lambda () (x y)))) 592 (lambda () 593 (av) 594 (let ((tt (lambda () (av) (x y)))) 595 (tt) 596 (lambda () 597 (let ([zz (lambda () (x y))]) 598 (begin (zz) 3))))))))) 599 (lambda (z) (set! ls (cons z ls))) 600 17)))]) 601 (cons v ls))) 602 '(3 17 17 17 17)) 603 ; tt goes away, zz can't borrow 604 (equal? 605 (let ([ls '()]) 606 (let ([v ((((parameterize ([run-cp0 (lambda (cp0 x) x)]) 607 (eval '(lambda (x y) 608 (let ((av (lambda () (x y)))) 609 (lambda () 610 (av) 611 (let ((tt (lambda () (av) (x y)))) 612 (lambda () 613 (let ([zz (lambda () (x y))]) 614 (begin (zz) 3))))))))) 615 (lambda (z) (set! ls (cons z ls))) 616 17)))]) 617 (cons v ls))) 618 '(3 17 17)) 619 ; regression test for bug in which $flonum-exponent read past mapped memory 620 (eq? 621 (do ([n 2000 (- n 1)] [ls (iota 2000)]) 622 ((= n 0) 'fini) 623 (map (lambda (x) (let ([x (exact (sqrt -2.0))]) x)) ls)) 624 'fini) 625) 626 627(mat compiler3 628 ;; test cpr0 code to avoid bombing with compile-time error for apparent 629 ;; arg count mismatch in direct call 630 ;; need to add tests for mvcall and mvlet as well. 631 (equal? 632 (let ((ip (open-input-string "#f"))) 633 (let ((consumer (lambda (x) (list x)))) 634 (if (read ip) (consumer 1 2) (consumer 4)))) 635 '(4)) 636 ;; error message should come at run time, warning at compile time. 637 (guard (c [(warning? c) #t]) 638 (with-output-to-file "testfile.ss" 639 (lambda () 640 (pretty-print 641 '(let ([ip (open-input-string "#t")]) 642 (let ([consumer (lambda (x) (list x))]) 643 (if (read ip) (consumer 1 2) (consumer 4)))))) 644 'replace) 645 (load "testfile.ss") 646 #f) 647 (error? ; incorrect argument count 648 (load "testfile.ss")) 649 (error? 650 (let ((ip (open-input-string "#t"))) 651 (let ((consumer (lambda (x) (list x)))) 652 (if (read ip) (consumer 1 2) (consumer 4))))) 653 ; test proper nonprocedure-procedure handling; goto is used as a symbol 654 ; but not given a value in compiler boot file. we had been failing to 655 ; run retrofit_nonprocedure_procedure after loading the second (compiler) 656 ; boot file. 657 (begin 658 (define $goto (lambda () (goto))) 659 #t) 660 (error? ($goto)) 661 ; check for nonprocedure-procedure handling when procedure is bound 662 ; to something other than a procedure 663 (error? (3 4)) 664 (error? ((cons 'a 'b) 4)) 665 ; check to make sure rest list is created after arguments are evaluated 666 (begin 667 (define non-eq-spines? 668 (lambda (x) 669 (let f ([ls1 (car x)] [ls2 (cdr x)]) 670 (if (null? ls1) 671 (null? ls2) 672 (and (not (eq? ls1 ls2)) 673 (eq? (car ls1) (car ls2)) 674 (f (cdr ls1) (cdr ls2))))))) 675 #t) 676 (non-eq-spines? 677 (let () 678 (define *k*) 679 (define (f) 680 (define (f . args) args) 681 (let ([ls (f (call/cc values) 1 2 3)]) (*k* ls))) 682 (define ls1 (call/cc (lambda (k) (set! *k* k) (f)))) 683 (define ls2 (call/cc (lambda (k) (set! *k* k) ((car ls1) (car ls1))))) 684 (cons ls1 ls2))) 685 (non-eq-spines? 686 (let () 687 (define *k*) 688 (define (f) 689 (define (f a . args) (cons a args)) 690 (let ([ls (f (call/cc values) 1 2 3)]) (*k* ls))) 691 (define ls1 (call/cc (lambda (k) (set! *k* k) (f)))) 692 (define ls2 (call/cc (lambda (k) (set! *k* k) ((car ls1) (car ls1))))) 693 (cons ls1 ls2))) 694 (non-eq-spines? 695 (let () 696 (define *k*) 697 (define (f) 698 (define (f . args) args) 699 (let ([ls (f 1 (call/cc values) 2 3)]) (*k* ls))) 700 (define ls1 (call/cc (lambda (k) (set! *k* k) (f)))) 701 (define ls2 (call/cc (lambda (k) (set! *k* k) ((cadr ls1) (cadr ls1))))) 702 (cons ls1 ls2))) 703 (non-eq-spines? 704 (let () 705 (define *k*) 706 (define (f) 707 (define (f a . args) (cons a args)) 708 (let ([ls (f 1 (call/cc values) 2 3)]) (*k* ls))) 709 (define ls1 (call/cc (lambda (k) (set! *k* k) (f)))) 710 (define ls2 (call/cc (lambda (k) (set! *k* k) ((cadr ls1) (cadr ls1))))) 711 (cons ls1 ls2))) 712 (non-eq-spines? 713 (let () 714 (define *k*) 715 (define (f) 716 (define (f a . args) (cons a args)) 717 (let ([ls (f 1 2 (call/cc values) 3)]) (*k* ls))) 718 (define ls1 (call/cc (lambda (k) (set! *k* k) (f)))) 719 (define ls2 (call/cc (lambda (k) (set! *k* k) ((caddr ls1) (caddr ls1))))) 720 (cons ls1 ls2))) 721 (non-eq-spines? 722 (let () 723 (define *k*) 724 (define (f) 725 (define (f . args) args) 726 (let ([ls (f 1 2 3 (call/cc values))]) (*k* ls))) 727 (define ls1 (call/cc (lambda (k) (set! *k* k) (f)))) 728 (define ls2 (call/cc (lambda (k) (set! *k* k) ((cadddr ls1) (cadddr ls1))))) 729 (cons ls1 ls2))) 730 (non-eq-spines? 731 (let () 732 (define *k*) 733 (define (f) 734 (define (f a . args) (cons a args)) 735 (let ([ls (f 1 2 3 (call/cc values))]) (*k* ls))) 736 (define ls1 (call/cc (lambda (k) (set! *k* k) (f)))) 737 (define ls2 (call/cc (lambda (k) (set! *k* k) ((cadddr ls1) (cadddr ls1))))) 738 (cons ls1 ls2))) 739 ; same thing, with direct lambda applications (should complete the set) 740 (non-eq-spines? 741 (let () 742 (define *k*) 743 (define (f) 744 (let ([ls ((lambda (a . args) (cons a args)) (call/cc values) 1 2 3)]) (*k* ls))) 745 (define ls1 (call/cc (lambda (k) (set! *k* k) (f)))) 746 (define ls2 (call/cc (lambda (k) (set! *k* k) ((car ls1) (car ls1))))) 747 (cons ls1 ls2))) 748 ; same thing, with let-values (should complete the set) 749 (non-eq-spines? 750 (let () 751 (define *k*) 752 (define (f) 753 (let ([ls (let-values ([(a . args) (values (call/cc values) 1 2 3)]) (cons a args))]) (*k* ls))) 754 (define ls1 (call/cc (lambda (k) (set! *k* k) (f)))) 755 (define ls2 (call/cc (lambda (k) (set! *k* k) ((car ls1) (car ls1))))) 756 (cons ls1 ls2))) 757 ; make sure trivial cwv produces same code as let 758 ((lambda (s1 s2) 759 (call-with-port 760 (open-string-input-port s1) 761 (lambda (p1) 762 (call-with-port 763 (open-string-input-port s2) 764 (lambda (p2) 765 (let loop () 766 (if (eof-object? (get-line p1)) 767 (eof-object? (get-line p2)) 768 (and (not (eof-object? (get-line p2))) 769 (loop))))))))) 770 (with-output-to-string 771 (lambda () 772 (parameterize ([gensym-count 0] [print-gensym #f] [#%$assembly-output #t] [#%$suppress-primitive-inlining #f]) 773 (eval '(lambda (x) 774 (let () 775 (import scheme) 776 (call-with-values (lambda () (x)) (lambda (y) (x y))))))))) 777 (with-output-to-string 778 (lambda () 779 (parameterize ([gensym-count 0] [print-gensym #f] [#%$assembly-output #t]) 780 (eval '(lambda (x) (let ([y (x)]) (x y)))))))) 781 ) 782 783(mat compiler4 784 ; check for overly loose loop recognition 785 (eq? (let ([f (lambda (t) 786 ((letrec ([merge 787 (case-lambda [(t) (merge t t)] [(i t) 'yes])]) 788 merge) 789 t))]) 790 (f 3)) 791 'yes) 792 (eq? (let ([f (lambda (t) 793 (define merge (case-lambda [(t) (merge t t)] [(i t) 'yes])) 794 (merge t))]) 795 (f 3)) 796 'yes) 797 ; original program from Bob Burger for overly loose loop recognition 798 (equal? 799 (let () 800 (define (consolidate T) 801 (define merge 802 (case-lambda 803 [(T) (if (null? T) '() (merge (car T) (cdr T)))] 804 [(I T) 805 (if (null? T) (cons I '()) (merge I (car T) (cdr T)))] 806 [(I J T) 807 (let ([I-hi (cdr I)]) 808 (if (<= (car J) I-hi) 809 (let ([J-hi (cdr J)]) 810 (if (<= J-hi I-hi) 811 (merge I T) 812 (merge (cons (car I) J-hi) T))) 813 (cons I (merge J T))))])) 814 (merge T)) 815 (consolidate '((1 . 2) (2 . 5)))) 816 '((1 . 5))) 817 ) 818 819(mat argcnt-check 820 (eqv? (let ((f (lambda (x) #t))) (set! f (lambda (x y) x)) (f 1 2)) 1) 821 (error? (let ((f (lambda (x) x))) (f 1 2))) 822 (let ((f (case-lambda ((x) x) ((x y) #t)))) (f 1 2)) 823 (error? (let ((f (case-lambda ((x) x) ((x y) x)))) (f 1 2 3))) 824 (let ((f (case-lambda ((x) x) ((x . y) #t)))) (f 1 2 3)) 825 (error? (let ((f (lambda (x y z . r) x))) (f))) 826 (error? (let ((f (lambda (x y z . r) x))) (f 1))) 827 (error? (let ((f (lambda (x y z . r) x))) (f 1 2))) 828 (eqv? (let ((f (lambda (x y z . r) x))) (f 1 2 3)) 1) 829 (eqv? (let ((f (lambda (x y z . r) x))) (f 1 2 3 4)) 1) 830 (eqv? (let ((f (lambda (x y z . r) x))) (f 1 2 3 4 5)) 1) 831 (let ((f (case-lambda ((x . r) x) ((x y . r) y)))) (f #t)) 832 (let ((f (case-lambda ((x y . r) y) ((x . r) x)))) (f #t)) 833 (error? (let f ((x 3)) (f))) 834 (let f ((x #f)) (or x (f #t))) 835 (let f ((x #f) (y #t)) (or x (f y x))) 836 (error? (let f ((x #f) (y #t)) (or x (f #t)))) 837 (let ((f (or (lambda (x) x) (lambda (x y) x)))) (f #t)) 838 (error? (let ((f (or 3 (lambda (x) x)))) (f #t))) 839 (guard (c [(equal? (condition-message c) "incorrect argument count in call ~a") #t] 840 [else (raise c)]) 841 (let loop ([x 1]) 842 (if (fx= x 0) 843 x 844 (loop))) 845 #f) 846 (begin 847 (with-output-to-file "testfile-argcnt-check-loop.ss" 848 (lambda () 849 (pretty-print 850 '(let loop ([x 1]) 851 (if (fx= x 0) 852 x 853 (loop))))) 854 'replace) 855 #t) 856 (guard (c [(equal? (condition-message c) "possible incorrect argument count in call ~a") #t] 857 [else #f]) 858 (load "testfile-argcnt-check-loop.ss") 859 #f) 860 (guard (c [(equal? (condition-message c) "possible incorrect argument count in call ~a") #t] 861 [else #f]) 862 (compile-library "testfile-argcnt-check-loop.ss") 863 #f) 864 (begin 865 (define foo 866 (lambda () 867 (let loop ([x 1]) 868 (if (fx= x 0) 869 x 870 (loop))))) 871 #t) 872 (guard (c [(equal? (condition-message c) "incorrect argument count in call ~a") #t] 873 [else (raise c)]) 874 (foo) 875 #f) 876 (begin 877 (with-output-to-file "testfile-argcnt-check-foo.ss" 878 (lambda () 879 (pretty-print 880 '(define foo 881 (lambda () 882 (let loop ([x 1]) 883 (if (fx= x 0) 884 x 885 (loop))))))) 886 'replace) 887 #t) 888 (guard (c [(equal? (condition-message c) "possible incorrect argument count in call ~a") #t] 889 [else #f]) 890 (load "testfile-argcnt-check-foo.ss")) 891 (guard (c [(equal? (condition-message c) "possible incorrect argument count in call ~a") #t] 892 [else #f]) 893 (compile-library "testfile-argcnt-check-foo.ss")) 894 (begin 895 (library (argcnt-check-r) 896 (export foo) 897 (import (chezscheme)) 898 (define foo 899 (lambda () 900 (let f ([x 1]) 901 (if (fx= x 0) 902 x 903 (list (f))))))) 904 #t) 905 (guard (c [(equal? (condition-message c) "incorrect argument count in call ~a") #t] 906 [else (raise c)]) 907 (let () 908 (import (argcnt-check-r)) 909 (foo) 910 #f)) 911 (begin 912 (library (argcnt-check-s) 913 (export foo foo1 foo2) 914 (import (chezscheme)) 915 (define foo 916 (lambda () 917 (let loop ([x 1]) 918 (if (fx= x 0) 919 x 920 (loop))))) 921 (define foo1 (lambda () (foo) (foo) (foo) (foo) (foo))) 922 (define foo2 (lambda () (foo)))) 923 #t) 924 (guard (c [(equal? (condition-message c) "incorrect argument count in call ~a") #t] 925 [else (raise c)]) 926 (let () 927 (import (argcnt-check-s)) 928 (foo) 929 #f)) 930 (guard (c [(equal? (condition-message c) "incorrect argument count in call ~a") #t] 931 [else (raise c)]) 932 (let () 933 (import (argcnt-check-s)) 934 (foo1) 935 #f)) 936 (guard (c [(equal? (condition-message c) "incorrect argument count in call ~a") #t] 937 [else (raise c)]) 938 (let () 939 (import (argcnt-check-s)) 940 (foo2) 941 #f)) 942 (begin 943 (with-output-to-file "testfile-argcnt-check-s.ss" 944 (lambda () 945 (pretty-print 946 '(library (testfile-argcnt-check-s) 947 (export foo) 948 (import (chezscheme)) 949 (define foo 950 (lambda () 951 (let loop ([x 1]) 952 (if (fx= x 0) 953 x 954 (loop)))))))) 955 'replace) 956 #t) 957 (guard (c [(equal? (condition-message c) "possible incorrect argument count in call ~a") #t] 958 [else (raise c)]) 959 (eval '(import (testfile-argcnt-check-s))) 960 #f) 961 (guard (c [(equal? (condition-message c) "possible incorrect argument count in call ~a") #t] 962 [else (raise c)]) 963 (load "testfile-argcnt-check-s.ss") 964 #f) 965 (guard (c [(equal? (condition-message c) "possible incorrect argument count in call ~a") #t] 966 [else (raise c)]) 967 (compile-library "testfile-argcnt-check-s.ss") 968 #f) 969) 970 971(mat direct-call 972 (let () 973 (define f (let ((x 3)) (lambda (y) (+ x y)))) 974 (define g (lambda () (f 4))) 975 (eq? (g) 7)) 976) 977 978(mat inspect ; need lots more 979 (eq? ((call/cc inspect/object) 'type) 'continuation) 980 (eq? ((call/1cc inspect/object) 'type) 'continuation) 981 (integer? ((call/cc inspect/object) 'depth)) 982 (integer? ((call/1cc inspect/object) 'depth)) 983 (error? ((inspect/object '#(1)) 'ref)) 984 (or (equal? (current-eval) interpret) 985 (let () 986 (define $f (lambda (x) (let ([o (call/cc inspect/object)]) (cons x o)))) 987 (let ([q ($f (cons 'a 'b))]) 988 (eq? ((cdr q) 'eval 'x) (car q))))) 989 (error? ; invalid message 990 ((inspect/object (cons 'car 'cdr)) 'creep)) 991 (error? ; incorrect number of arguments 992 ((inspect/object (cons 'car 'cdr)) 'size)) 993 (error? ; invalid generation 994 ((inspect/object (cons 'car 'cdr)) 'size 'oops)) 995 (<= ((inspect/object (cons 'car 'cdr)) 'size 0) (fx* (ftype-sizeof uptr) 2)) 996 (eqv? ((inspect/object (cons 0 0)) 'size 'static) (fx* (ftype-sizeof uptr) 2)) 997 (equal? 998 (let ([ls (list 0 0)]) 999 (set-cdr! (cdr ls) ls) 1000 (let ([x (inspect/object ls)]) 1001 (let* ([size1 (x 'size 'static)] [size2 ((x 'cdr) 'size 'static)]) 1002 (cons size1 size2)))) 1003 (cons 1004 (fx* (ftype-sizeof uptr) 4) 1005 (fx* (ftype-sizeof uptr) 2))) 1006) 1007 1008(mat compute-size 1009 (error? (compute-size 0 -1)) 1010 (error? (compute-size 0 'dynamic)) 1011 (eqv? (compute-size 0) 0) 1012 (eqv? (compute-size (cons 0 0)) (fx* (ftype-sizeof uptr) 2)) 1013 (eqv? (compute-size 'cons) 0) 1014 ; from the user's guide 1015 (eqv? 1016 (compute-size 0) 1017 0) 1018 (eqv? 1019 (compute-size (cons 0 0)) 1020 (* (ftype-sizeof uptr) 2)) 1021 (eqv? 1022 (compute-size (cons (vector #t #f) 0)) 1023 (* (ftype-sizeof uptr) 6)) 1024 (eqv? 1025 (compute-size 1026 (let ([x (cons 0 0)]) 1027 (set-car! x x) 1028 (set-cdr! x x) 1029 x)) 1030 (* (ftype-sizeof uptr) 2)) 1031 (>= 1032 (let () 1033 (define-record-type frob (fields x)) 1034 (compute-size 1035 (let ([x (make-frob 0)]) 1036 (cons x x)))) 1037 (* (ftype-sizeof uptr) 16)) 1038 (eqv? 1039 (parameterize ([collect-request-handler void]) 1040 (let () 1041 (define-record-type frob (fields x)) 1042 (collect 1 1) 1043 (compute-size 1044 (let ([x (make-frob 0)]) 1045 (cons x x)) 1046 0))) 1047 (* (ftype-sizeof uptr) 4)) 1048 ; make sure we don't venture into the undefined fields of a shot 1-shot continuation 1049 (fixnum? (let ([k (call/1cc (lambda (k) k))]) (collect) (compute-size k))) 1050) 1051 1052(mat compute-size-increments 1053 (error? (compute-size-increments 'not-a-list)) 1054 (error? (compute-size-increments 0)) 1055 (error? (compute-size-increments (list 0) -1)) 1056 (error? (compute-size-increments (list 0) "static")) 1057 (error? (compute-size-increments (list 0) '())) 1058 (begin 1059 (define pair-size (compute-size (cons 1 2))) 1060 (define ephemeron-size (compute-size (ephemeron-cons 1 2))) 1061 #t) 1062 (equal? (list pair-size pair-size) 1063 (compute-size-increments (list (cons 1 2) (cons 3 4)))) 1064 (equal? (list (* 3 pair-size) pair-size) 1065 (let ([l (list 1 2)]) 1066 (compute-size-increments (list (cons 3 l) (cons 4 l))))) 1067 (equal? (list pair-size) 1068 (compute-size-increments (list (weak-cons (make-bytevector 100) #f)))) 1069 (let* ([x (make-bytevector 100)] 1070 [ls (list (lambda () x) x)]) 1071 (equal? (compute-size-increments ls) 1072 (reverse (compute-size-increments (reverse ls))))) 1073 ;; Ephemeron(s) found before key: 1074 (equal? (list ephemeron-size (* 2 pair-size)) 1075 (compute-size-increments (let* ([p (cons 0 0)] 1076 [e (ephemeron-cons p (cons 0 0))]) 1077 (list e p)))) 1078 (equal? (list ephemeron-size (* 3 pair-size)) 1079 (let* ([v (cons 1 2)] 1080 [e (ephemeron-cons v (cons 3 4))]) 1081 (compute-size-increments (list e (cons v #f))))) 1082 (equal? (list (* 2 (+ ephemeron-size pair-size)) (* 4 pair-size)) 1083 (let* ([v (cons 1 2)] 1084 [e* (list (ephemeron-cons v (cons 3 4)) 1085 (ephemeron-cons v (cons 5 6)))]) 1086 (compute-size-increments (list e* (cons v #f))))) 1087 ;; Key found before ephemeron(s): 1088 (equal? (list (* 2 pair-size) (+ ephemeron-size pair-size)) 1089 (let* ([v (cons 1 2)] 1090 [e (ephemeron-cons v (cons 3 4))]) 1091 (compute-size-increments (list (cons v #f) e)))) 1092 (equal? (list (* 2 pair-size) (+ (* 4 pair-size) (* 2 ephemeron-size))) 1093 (let* ([v (cons 1 2)] 1094 [e* (list (ephemeron-cons v (cons 3 4)) 1095 (ephemeron-cons v (cons 5 6)))]) 1096 (compute-size-increments (list (cons v #f) e*)))) 1097 ;; This call will encounter many kinds of objects, just to make 1098 ;; sure it doesn't fail: 1099 (list? (compute-size-increments (list (call/cc values)) 'static)) 1100 ;; Check that a deactivated thread's continuation can be traversed 1101 ;; for `compute-size-increments`: 1102 (or (not (threaded?)) 1103 (let* ([ready (box #f)] 1104 [saved (box #f)] 1105 [m (make-mutex)] 1106 [N 1000000] 1107 [pause-until (lambda (check) 1108 (let loop () 1109 (unless (check) 1110 (sleep (make-time 'time-duration 10000 0)) 1111 (loop))))]) 1112 (mutex-acquire m) 1113 (let ([th (fork-thread 1114 (lambda () 1115 (let ([bstr (make-bytevector N)]) 1116 (set-box! ready 'go) 1117 ;; Block so that thread becomes deactivated 1118 (mutex-acquire m) 1119 (mutex-release m) 1120 ;; bstr is retained in the thread's continuation until here 1121 (set-box! saved (bytevector-u8-ref bstr 0)) 1122 (pause-until (lambda () (box-cas! ready 'finish 'done))) 1123 ;; Block so that thread becomes deactivated, again 1124 (mutex-acquire m) 1125 (mutex-release m))))]) 1126 ;; Wait for thread to start 1127 (pause-until (lambda () (eq? 'go (unbox ready)))) 1128 ;; Wait for thread to become inactive, blocked on the mutex 1129 (pause-until (lambda () (= 1 (#%$top-level-value '$active-threads)))) 1130 ;; Get thread's size, which should include bstr 1131 (let ([pre-sizes (compute-size-increments (list th))]) 1132 (mutex-release m) 1133 ;; Wait for bytevector to be discarded in the thread 1134 (pause-until (lambda () (unbox saved))) 1135 (mutex-acquire m) 1136 (set-box! ready 'finish) 1137 ;; Wait for thread to become inactive again 1138 (pause-until (lambda () (= 1 (#%$top-level-value '$active-threads)))) 1139 ;; Get thread's size, which shouldn't include bstr 1140 (let ([post-sizes (compute-size-increments (list th))]) 1141 (mutex-release m) 1142 ;; Wait for thread to exit 1143 (let () 1144 (define $threads (foreign-procedure "(cs)threads" () scheme-object)) 1145 (pause-until (lambda () (= 1 (length ($threads)))))) 1146 ;; Make sure `compute-size-increments` doesn't crash on a 1147 ;; terminated thread: 1148 (compute-size-increments (list th)) 1149 ;; Main result: detected size of `bstr` in the thread 1150 ;; while it was part of the continuation 1151 (or (eq? (current-eval) interpret) ; interpreter continuation is not precise enough 1152 (and (> (car pre-sizes) N) 1153 (< (car post-sizes) N)))))))) 1154 ) 1155 1156(mat collect+compute-size-increments 1157 (eq? (void) (collect 0 0 0 #f)) 1158 (eq? '() (collect 0 0 0 '())) 1159 1160 (error? (collect 0 0 0 'not-a-list)) 1161 (error? (collect 0 0 0 0)) 1162 (error? (collect 'not-a-generation 0 0 '())) 1163 (error? (collect 0 'not-a-generation 0 '())) 1164 (error? (collect 0 0 'not-a-generation '())) 1165 (error? (collect 1 0 0 '())) 1166 1167 (begin 1168 (define-record-type count-wrap (fields val)) 1169 (collect 0 0 0 (list (make-count-wrap 0))) ; take care of one-time initialization costs 1170 (define wrap-size (car (collect 0 0 0 (list (make-count-wrap 0))))) ; includes rtd 1171 (define just-wrap-size (cadr (collect 0 0 0 (list (make-count-wrap 0) (make-count-wrap 1))))) 1172 (define pair-size (compute-size (cons 1 2))) 1173 (define ephemeron-size (compute-size (ephemeron-cons 1 2))) 1174 #t) 1175 (equal? (list pair-size pair-size) 1176 (collect 0 0 0 (list (cons 1 2) (cons 3 4)))) 1177 (equal? (list (* 3 pair-size) pair-size) 1178 (let ([l (list 1 2)]) 1179 (collect 0 0 0 (list (cons 3 l) (cons 4 l))))) 1180 (equal? (list pair-size) 1181 (collect 0 0 0 (list (weak-cons (make-bytevector 100) #f)))) 1182 ;; Ephemeron(s) found before key: 1183 (equal? (list ephemeron-size (+ (* 2 pair-size) wrap-size)) 1184 (collect 0 0 0 (let* ([p (make-count-wrap (cons 0 0))] 1185 [e (ephemeron-cons p (cons 0 0))]) 1186 (list e p)))) 1187 (equal? (list ephemeron-size (+ (* 3 pair-size) wrap-size)) 1188 (let* ([v (make-count-wrap (cons 1 2))] 1189 [e (ephemeron-cons v (cons 3 4))]) 1190 (collect 0 0 0 (list e (cons v #f))))) 1191 (equal? (list (* 2 (+ ephemeron-size pair-size)) (+ (* 4 pair-size) wrap-size)) 1192 (let* ([v (make-count-wrap (cons 1 2))] 1193 [e* (list (ephemeron-cons v (cons 3 4)) 1194 (ephemeron-cons v (cons 5 6)))]) 1195 (collect 0 0 0 (list e* (cons v #f))))) 1196 ;; Key found before ephemeron(s): 1197 (equal? (list (+ (* 2 pair-size) wrap-size) (+ ephemeron-size pair-size)) 1198 (let* ([v (make-count-wrap (cons 1 2))] 1199 [e (ephemeron-cons v (cons 3 4))]) 1200 (collect 0 0 0 (list (cons v #f) e)))) 1201 (equal? (list (* 2 pair-size) (+ (* 4 pair-size) (* 2 ephemeron-size))) 1202 (let* ([v (cons 1 2)] 1203 [e* (list (ephemeron-cons v (cons 3 4)) 1204 (ephemeron-cons v (cons 5 6)))]) 1205 (collect 0 0 0 (list (cons v #f) e*)))) 1206 ;; Weakly held objects: 1207 (equal? '(0) 1208 (let* ([v (make-count-wrap (cons 1 2))] 1209 [ls (weak-cons v '())]) 1210 (collect 0 0 0 ls))) 1211 (equal? (list wrap-size pair-size (+ just-wrap-size pair-size)) 1212 (let* ([v (make-count-wrap (cons 1 2))] 1213 [ls (cons* (make-count-wrap 0) (cons v 1) (weak-cons v '()))]) 1214 (collect 0 0 0 ls))) 1215 (equal? (list 0 (+ wrap-size (* 2 pair-size))) 1216 (let* ([v (make-count-wrap (cons 1 2))] 1217 [ls (weak-cons v (cons (cons v 1) '()))]) 1218 (collect 0 0 0 ls))) 1219 (equal? #!bwp 1220 (let* ([v (make-count-wrap (cons 1 2))] 1221 [ls (weak-cons v '())]) 1222 (collect 0 0 0 ls) 1223 (car ls))) 1224 ;; These calls will encounter many kinds of objects, just to make 1225 ;; sure they don't fail: 1226 (list? (collect 0 0 0 (list (call/cc values)))) 1227 (list? (collect (collect-maximum-generation) (collect-maximum-generation) (collect-maximum-generation) (list (call/cc values)))) 1228 1229 (let () 1230 (define e (ephemeron-cons #t (gensym))) 1231 (collect 0 1) 1232 (let ([g (gensym)]) 1233 (set-car! e g) 1234 (set! g #f) 1235 ;; For this collection, `e` is both on the dirty list 1236 ;; and involved in measuring; make sure those roles 1237 ;; don't conflict 1238 (collect 1 1 1 (list e)) 1239 (equal? e (cons #!bwp #!bwp)))) 1240 1241 (let () 1242 (define e (ephemeron-cons #t 'other)) 1243 (collect 0 1) 1244 (let ([g (gensym)]) 1245 (set-car! e g) 1246 (collect 1 1 1 (list e)) 1247 (equal? e (cons g 'other)))) 1248) 1249 1250(mat compute-composition 1251 (error? (compute-composition 0 -1)) 1252 (error? (compute-composition 0 "static")) 1253 (equal? (compute-composition 0) '()) 1254 (equal? 1255 (sort (lambda (x y) (fx> (cadr x) (cadr y))) 1256 (compute-composition (cons (fxvector 1) (vector (fxvector 2) (fxvector 3) (list (fxvector 4)))))) 1257 `((fxvector . (4 . ,(fx* 4 (ftype-sizeof uptr) 2))) (pair . (2 . ,(fx* 2 (ftype-sizeof uptr) 2))) (vector . (1 . ,(fx* 4 (ftype-sizeof uptr)))))) 1258 (equal? (compute-composition 'cons) '()) 1259 ; from the user's guide 1260 (begin 1261 (define $same-elements? 1262 (lambda (ls1 ls2) 1263 (and (equal? (length ls1) (length ls2)) 1264 (let f ([ls1 ls1]) 1265 (or (null? ls1) 1266 (and (member (car ls1) ls2) 1267 (f (cdr ls1)))))))) 1268 #t) 1269 (equal? 1270 (compute-composition 0) 1271 '()) 1272 ($same-elements? 1273 (compute-composition (cons 0 0)) 1274 `((pair 1 . ,(* (ftype-sizeof uptr) 2)))) 1275 (equal? 1276 (compute-composition (cons (vector #t #f) 0)) 1277 `((pair 1 . ,(* (ftype-sizeof uptr) 2)) 1278 (vector 1 . ,(* (ftype-sizeof uptr) 4)))) 1279 (equal? 1280 (compute-composition 1281 (let ([x (cons 0 0)]) 1282 (set-car! x x) 1283 (set-cdr! x x) 1284 x)) 1285 `((pair 1 . ,(* (ftype-sizeof uptr) 2)))) 1286 (>= 1287 (let () 1288 (define-record-type frob (fields x)) 1289 (length 1290 (compute-composition 1291 (let ([x (make-frob 0)]) 1292 (cons x x))))) 1293 4) ; pair, rtd, record, fields vector, name 1294 (let () 1295 (define-record-type frob (fields x)) 1296 ($same-elements? 1297 (parameterize ([collect-request-handler void]) 1298 (let () 1299 (collect 1 1) 1300 (compute-composition 1301 (let ([x (make-frob 0)]) 1302 (cons x x)) 1303 0))) 1304 `((pair 1 . ,(* (ftype-sizeof uptr) 2)) 1305 (,(record-type-descriptor frob) 1 . ,(* (ftype-sizeof uptr) 2))))) 1306 ; make sure we don't venture into the undefined fields of a shot 1-shot continuation 1307 (list? (let ([k (call/1cc (lambda (k) k))]) (collect) (compute-composition k))) 1308) 1309 1310(mat make-object-finder 1311 (begin 1312 (define $fo 1313 (lambda args 1314 (let ([find-next (apply make-object-finder args)]) 1315 (cond 1316 [(find-next) => 1317 (lambda (path) 1318 (unless (list? path) 1319 (errorf '$fo-all "~s is not a list" path)) 1320 path)] 1321 [else #f])))) 1322 (define $fo-all 1323 (lambda args 1324 (let ([find-next (apply make-object-finder args)]) 1325 (let f () 1326 (cond 1327 [(find-next) => 1328 (lambda (path) 1329 (unless (list? path) 1330 (errorf '$fo-all "~s is not a list" path)) 1331 (cons path (f)))] 1332 [else '()]))))) 1333 (define set-equal? 1334 (lambda (s1 s2) 1335 (and (= (length s1) (length s2)) 1336 (andmap (lambda (x) (member x s2)) s1) 1337 #t))) 1338 #t) 1339 (error? ; not a procedure 1340 (make-object-finder 17)) 1341 (error? ; invalid generation 1342 (make-object-finder not 'q (+ (collect-maximum-generation) 1))) 1343 (error? ; invalid generation 1344 (make-object-finder not 'q 'oldgen)) 1345 (error? ; invalid generation 1346 (make-object-finder not 'q -1)) 1347 (error? ; invalid number of arguments 1348 ((make-object-finder fixnum? 1) 'a)) 1349 (not ($fo (let ([ctr 0]) (lambda (x) (set! ctr (+ ctr 1)) (when (= (mod ctr 4000) 0) (pretty-print ctr)) #f)))) 1350 (pair? ($fo symbol?)) 1351 (not ($fo symbol? (list 1 2 3))) 1352 (equal? 1353 ($fo symbol? (list 1 'a-symbol-probably-not-static 3)) 1354 '(a-symbol-probably-not-static (a-symbol-probably-not-static 3) (1 a-symbol-probably-not-static 3))) 1355 (equal? 1356 ($fo symbol? (list 1 'a 3)) 1357 '(a (a 3) (1 a 3))) 1358 (equal? 1359 ($fo symbol? (list 'a-symbol-probably-not-static 2 3)) 1360 '(a-symbol-probably-not-static (a-symbol-probably-not-static 2 3))) 1361 (equal? 1362 ($fo symbol? (list 'a 2 3)) 1363 '(a (a 2 3))) 1364 (equal? 1365 ($fo flonum? (list 1 3.14 3)) 1366 '(3.14 (3.14 3) (1 3.14 3))) 1367 (not ($fo symbol? (vector 1 2 3))) 1368 (equal? 1369 ($fo symbol? (vector 1 'a-symbol-probably-not-static 3)) 1370 '(a-symbol-probably-not-static #(1 a-symbol-probably-not-static 3))) 1371 (equal? 1372 ($fo flonum? (vector 1 3.14 3)) 1373 '(3.14 #(1 3.14 3))) 1374 (equal? 1375 ($fo fixnum? (vector 1 'a-symbol-probably-not-static 3)) 1376 '(1 #(1 a-symbol-probably-not-static 3))) 1377 (equal? 1378 ($fo-all fixnum? 1) 1379 '((1))) 1380 (set-equal? 1381 ($fo-all fixnum? (vector 1 'a-symbol-probably-not-static 3)) 1382 '((1 #(1 a-symbol-probably-not-static 3)) (3 #(1 a-symbol-probably-not-static 3)))) 1383 (set-equal? 1384 ($fo-all fixnum? (list 1 'a-symbol-probably-not-static 3)) 1385 '((1 (1 a-symbol-probably-not-static 3)) (3 (3) (a-symbol-probably-not-static 3) (1 a-symbol-probably-not-static 3)))) 1386 (let-values ([(g path*) (parameterize ([generate-inspector-information #f] 1387 [compile-profile #f] 1388 [current-eval compile] 1389 [enable-cp0 #f]) 1390 (eval `(let () 1391 (define f (lambda (x) (lambda (y) (cons x '#(4 5))))) 1392 (define g (f '#(a b))) 1393 (values g ($fo-all vector? g)))))]) 1394 (set-equal? 1395 path* 1396 `((#(4 5) ,(#%$closure-code g) ,g) 1397 (#(a b) ,g)))) 1398 (not ($fo (lambda (x) (and (string? x) (string=? x "cons"))) 'cons 0)) 1399 (list? ($fo (lambda (x) (and (string? x) (string=? x "cons"))) 'cons 'static)) 1400 ; make sure we don't venture into the undefined fields of a shot 1-shot continuation 1401 (not (let ([k (call/1cc (lambda (k) k))]) (collect) ($fo (lambda (x) #f) k))) 1402) 1403 1404(mat print-vector-length 1405 (not (print-vector-length)) 1406 (let ([p (open-output-string)]) 1407 (write '#(1 2 3) p) 1408 (string=? (get-output-string p) "#(1 2 3)")) 1409 (let ([p (open-output-string)]) 1410 (parameterize ([print-vector-length #t]) 1411 (write '#(1 2 3) p)) 1412 (string=? (get-output-string p) "#3(1 2 3)")) 1413 ) 1414 1415(mat print-brackets 1416 (print-brackets) 1417 (let ([p (open-output-string)]) 1418 (pretty-print '(let ([x x]) x) p) 1419 (string=? (get-output-string p) (format "(let ([x x]) x)~%"))) 1420 (let ([p (open-output-string)]) 1421 (parameterize ([print-brackets #f]) 1422 (pretty-print '(let ([x x]) x) p)) 1423 (string=? (get-output-string p) (format "(let ((x x)) x)~%"))) 1424 ) 1425 1426(mat subset 1427 (not (subset-mode)) 1428 (error? (subset-mode 'ieee)) 1429 (error? (subset-mode 'r4rs)) 1430 (error? (subset-mode 'r5rs)) 1431 (error? (subset-mode #t)) 1432 (begin (subset-mode #f) (not (subset-mode))) 1433) 1434 1435(mat eval 1436 (eq? (eval '(let ((x 3)) x)) 3) 1437 (eq? (eval '(let ((x 3)) x) (interaction-environment)) 3) 1438 (eq? (eval '(let ((x 3)) x) (scheme-report-environment 5)) 3) 1439 (eq? (eval '(let ((x 3)) x) (ieee-environment)) 3) 1440 (eq? (eval '(let ((x 3)) x) (null-environment 5)) 3) 1441 1442 (eq? (eval '(let ((p (delay 3))) (force p))) 3) 1443 (eq? (eval '(let ((p (delay 3))) (force p)) (interaction-environment)) 3) 1444 (eq? (eval '(let ((p (delay 3))) (force p)) (scheme-report-environment 5)) 3) 1445 (error? (eval '(let ((p (delay 3))) (force p)) (null-environment 5))) 1446 (error? (eval '(let ((p (delay 3))) (force p)) (ieee-environment))) 1447 1448 (error? (eval '(cons 1 2) (null-environment 5))) 1449 (error? (eval '(sort < '(3 2 4)) (scheme-report-environment 5))) 1450 (error? (eval '(sort < '(3 2 4)) (ieee-environment))) 1451 (error? (eval '(sort < '(3 2 4)) (null-environment 5))) 1452) 1453 1454(mat eval2 1455 (eq? (eval '(let ((x 3)) x)) 3) 1456 (eq? (eval '(let ((x 3)) x) (interaction-environment)) 3) 1457 (eq? (eval '(let ((x 3)) x) (scheme-report-environment 5)) 3) 1458 (eq? (eval '(let ((x 3)) x) (null-environment 5)) 3) 1459 (eq? (eval '(let ((x 3)) x) (ieee-environment)) 3) 1460 1461 (eq? (eval 'list) list) 1462 (eq? (eval 'list (interaction-environment)) list) 1463 (eq? (eval 'list (scheme-report-environment 5)) list) 1464 (error? (eval 'list (null-environment 5))) 1465 (eq? (eval 'list (ieee-environment)) list) 1466 1467 (eq? (eval 'force) force) 1468 (eq? (eval 'force (interaction-environment)) force) 1469 (eq? (eval 'force (scheme-report-environment 5)) force) 1470 (error? (eval 'force (null-environment 5))) 1471 (error? (eval 'force (ieee-environment))) 1472 1473 (eq? (force (eval '(delay 17))) 17) 1474 (eq? (force (eval '(delay 17) (interaction-environment))) 17) 1475 (eq? (force (eval '(delay 17) (scheme-report-environment 5))) 17) 1476 (eq? (force (eval '(delay 17) (null-environment 5))) 17) 1477 (error? (eval '(delay 17) (ieee-environment))) 1478 1479 (error? (eval '(set! + -) (scheme-report-environment 5))) 1480 (error? (eval '(set! + -) (null-environment 5))) 1481 (error? (eval '(set! + -) (ieee-environment))) 1482 1483 (error? (eval '(define x -) (scheme-report-environment 5))) 1484 (error? (eval '(define x -) (null-environment 5))) 1485 (error? (eval '(define x -) (ieee-environment))) 1486 1487 (error? (eval '(define-syntax x list) (scheme-report-environment 5))) 1488 (error? (eval '(define-syntax x list) (null-environment 5))) 1489 (error? (eval '(define-syntax x list) (ieee-environment))) 1490 (error? (eval '(define-syntax x (syntax-rules () ((_) 4))) 1491 (ieee-environment))) 1492 1493 (eq? (eval '(syntax-case 3 () (_ 4))) 4) 1494 (eq? (eval '(syntax-case 3 () (_ 4)) (interaction-environment)) 4) 1495 (error? (eval '(syntax-case 3 () (_ 4)) (scheme-report-environment 5))) 1496 (error? (eval '(syntax-case 3 () (_ 4)) (null-environment 5))) 1497 (error? (eval '(syntax-case 3 () (_ 4)) (ieee-environment))) 1498) 1499 1500(mat getenv/putenv 1501 (procedure? getenv) 1502 (procedure? putenv) 1503 (or (embedded?) 1504 (string? (or (getenv "HOME") (getenv "HOMEPATH")))) 1505 (not (getenv "FUBULYFRATZ")) 1506 (eq? (putenv "FUBULY" "FRATZ") (void)) 1507 (not (getenv "FUBULYFRATZ")) 1508 (equal? (getenv "FUBULY") "FRATZ") 1509 (eq? (putenv "FUBULY" "fratz") (void)) 1510 (equal? (getenv "FUBULY") "fratz") 1511 (error? (getenv 'hello)) 1512 (error? (putenv 'hello "goodbye")) 1513 (error? (putenv "hello" 'goodbye)) 1514 ) 1515 1516(mat source-directories 1517 (equal? (separate-eval '(source-directories)) "(\".\")\n") 1518 (equal? (parameterize ((source-directories (list "/a" "."))) 1519 (source-directories)) 1520 '("/a" ".")) 1521 (error? (source-directories 'a)) 1522 (error? (source-directories "a")) 1523 (error? (source-directories '("a" . "b"))) 1524 (error? (source-directories '(3))) 1525 (error? ; invalid exports list---not "testfile.ss not found in source directories" 1526 (begin 1527 (with-output-to-file "testfile.ss" 1528 (lambda () (pretty-print '(module (a 3) (define a 3)))) 1529 'replace) 1530 (parameterize ([source-directories '("." "probably not there")]) 1531 (load "testfile.ss")))) 1532) 1533 1534(mat queries 1535 (boolean? (threaded?)) 1536 (boolean? (petite?)) 1537 (let ([pid (get-process-id)]) 1538 (and (integer? pid) (exact? pid))) 1539 (eqv? (get-thread-id) 0) 1540 (eqv? (get-process-id) (get-process-id)) 1541 (eqv? (get-thread-id) (get-thread-id)) 1542) 1543 1544(mat cpletrec 1545 (eq? (letrec ((x 3)) x) 3) 1546 (eq? (letrec ((x 3)) 4) 4) 1547 (eq? (letrec ((x (let ((y 4)) (lambda (x) (+ x y))))) (x 7)) 11) 1548 (eq? (letrec ((x (letrec ((y 4)) (lambda (x) (+ x y))))) (x 7)) 11) 1549 (eq? (letrec ((x 4)) (set! x 3)) (void)) 1550 (eq? (letrec ((x 4)) (set! x (begin (write 'hi) 3))) (void)) 1551 (eq? (letrec ((x (letrec ((y (lambda (z) (+ z z)))) 1552 (lambda (x) (y x))))) 1553 (x 3)) 1554 6) 1555 (equal? (letrec ((foo (rec f (lambda (x ls) (list x ls))))) (foo 1 2)) 1556 '(1 2)) 1557 (eq? (letrec ((x (let ((a (+ 3 4))) (let ((b (+ a a))) b)))) x) 14) 1558 (eq? (letrec ((x (let ((a (lambda (x) (+ x 1)))) 1559 (let ((b (lambda (y) (+ (a y) y)))) 1560 (lambda (z) (* (b z) z)))))) 1561 (x 3)) 1562 21) 1563 (equal? 1564 (let () 1565 (define next 1566 (let ((cnt 0)) 1567 (lambda () (set! cnt (+ cnt 1)) cnt))) 1568 (define list-next 1569 (lambda () 1570 (list (next) (next)))) 1571 (sort < (cons (next) (list-next)))) 1572 '(1 2 3)) 1573 (record? 1574 ((let () 1575 (define-record foo (a b c)) 1576 make-foo) 1577 1 2 3)) 1578 (record? 1579 ((let () 1580 (define-record foo (a b c) (((mutable d) (+ a b)))) 1581 make-foo) 1582 1 2 3)) 1583 (record? 1584 ((let () 1585 (define-record foo (a b c)) 1586 make-foo) 1587 1 2 3)) 1588 (error? (letrec ((x (foreign-procedure "foo" () void))) (x 17))) 1589 (equal? 1590 (letrec ((x (let ((a 3) 1591 (b (letrec ((e (lambda (y) (eq? y x)))) 1592 (lambda () (e x)))) 1593 (d (let ((c 4)) (lambda () (+ 5 c))))) 1594 (lambda () 1595 (list a (b) (d)))))) 1596 (x)) 1597 '(3 #t 9)) 1598 (equal? 1599 (letrec ((x (let ((a 3) 1600 (b (letrec ((e (lambda (y) (eq? y x)))) 1601 (lambda () (e x)))) 1602 (d (let ((c 4)) (lambda () (+ 5 c))))) 1603 (lambda () 1604 (set! a (+ a 1)) 1605 (list a (b) (d)))))) 1606 (x)) 1607 '(4 #t 9)) 1608 (equal? 1609 (letrec ((x (let ((a 3)) 1610 (letrec ((b (lambda (x) (+ x 2))) 1611 (d (lambda (y) (* y y)))) 1612 (lambda () 1613 (set! a (+ a 1)) 1614 (list a (b a) (d a))))))) 1615 (x)) 1616 '(4 6 16)) 1617 (equal? 1618 (letrec ((x (let ((a 3)) 1619 (let ((b (letrec ((e (lambda (y) (eq? y x)))) 1620 (lambda () (e x)))) 1621 (d (let ((c 4)) (lambda () (+ a c))))) 1622 (lambda () 1623 (set! a (+ a 1)) 1624 (list a (b) (d))))))) 1625 (x)) 1626 '(4 #t 8)) 1627 #;(warning? 1628 (begin 1629 (define unknown (lambda (x) x)) 1630 (letrec ([foo (unknown (lambda () bar))] 1631 [bar (lambda () foo)]) 1632 foo))) 1633 #;(warning? 1634 (mat/cf 1635 (begin 1636 (define unknown (lambda (x) x)) 1637 (letrec ([foo (unknown (lambda () bar))] 1638 [bar (unknown (lambda () foo))]) 1639 foo)))) 1640 (error? 1641 (eval '(letrec* ([f (lambda () q)] [g (f)] [q 17]) g))) 1642 (error? 1643 (eval '(begin 1644 (define unknown (lambda (x) (x))) 1645 (letrec ([foo (unknown (lambda () bar))] 1646 [bar (lambda () foo)]) 1647 foo)))) 1648 (error? 1649 (eval '(mat/cf 1650 (begin 1651 (define unknown (lambda (x) (x))) 1652 (letrec ([foo (unknown (lambda () bar))] 1653 [bar (unknown (lambda () foo))]) 1654 foo))))) 1655 ; test cpvalid/undefer interaction 1656 (error? ; attempt to reference undefined variable b 1657 (letrec* ([d (letrec ([a (lambda () c)] [b 1] [c b]) 2)]) 3)) 1658 (error? ; attempt to reference undefined variable b 1659 (letrec* ([d (letrec ([a (lambda () 0)] [b 1] [c b]) 2)]) 3)) 1660 (error? ; attempt to reference undefined variable a 1661 (letrec* ([d (letrec ([a (lambda () 1)] [c a]) 2)]) 3)) 1662 (error? ; attempt to reference undefined variable b 1663 (letrec* ([d (letrec* ([a (lambda () 1)] [c b] [b 4]) 2)]) 3)) 1664 (error? ; attempt to reference undefined variable b 1665 (letrec* ([d (letrec ([a (set! b (lambda () 0))] [b 1]) 2)]) 3)) 1666 (eqv? 1667 (letrec* ([d (letrec ([a (lambda () 1)] [c (if #f a)]) 2)]) 3) 1668 3) 1669 (eqv? 1670 (letrec* ([d (letrec* ([a (lambda () 1)] [c (if #f b)] [b 4]) 2)]) 3) 1671 3) 1672 (eqv? 1673 (letrec* ([d (letrec ([a (if #f (set! b (lambda () 0)))] [b 1]) 2)]) 3) 1674 3) 1675 (eqv? 1676 (letrec* ([d (letrec ([a (lambda () 0)] [b 1] [c 2]) 2)]) 3) 1677 3) 1678 (procedure? (letrec* ([bar (letrec* ([f (lambda (x) f)]) f)]) bar)) 1679 (eqv? 1680 (letrec* ([d (letrec* ([a 0] [b (set! a (lambda () 1))]) 2)]) 3) 1681 3) 1682 ; make sure we don't get valid check(s) 1683 (equivalent-expansion? 1684 (parameterize ([run-cp0 (lambda (cp0 x) (cp0 x))] 1685 [optimize-level 2]) 1686 (expand/optimize 1687 '(let () 1688 (define f (lambda () (g))) 1689 (define g (lambda () 17)) 1690 (define x (f)) 1691 x))) 1692 '17) 1693 ; check for regression: cpvalid leaving behind a cpvalid-defer form 1694 (equivalent-expansion? 1695 (parameterize ([run-cp0 (lambda (cp0 x) x)] 1696 [optimize-level 2]) 1697 (expand/optimize '(letrec* ([f (letrec ([x x]) (lambda () x))]) 0))) 1698 '(let ([f (let ([valid? #f]) 1699 (let ([x (#2%void)]) 1700 (set! x 1701 (begin 1702 (if valid? 1703 (#2%void) 1704 (#2%$source-violation #f #f #t 1705 "attempt to reference undefined variable ~s" 'x)) 1706 x)) 1707 (set! valid? #t) 1708 (lambda () x)))]) 1709 0)) 1710) 1711 1712(mat generate-procedure-source-information 1713 (begin 1714 (define the-source 1715 (let ([sfd (make-source-file-descriptor "the-source.ss" (open-bytevector-input-port '#vu8()))]) 1716 (make-source-object sfd 10 20))) 1717 (define (make-proc full-inspect?) 1718 (parameterize ([generate-inspector-information full-inspect?] 1719 [generate-procedure-source-information #t]) 1720 (let ([e '(lambda (x) x)]) 1721 (compile (make-annotation e the-source e))))) 1722 (define proc-i (make-proc #t)) 1723 (define proc-n (make-proc #f)) 1724 (and (procedure? proc-i) 1725 (procedure? proc-n))) 1726 (equal? (((inspect/object proc-i) 'code) 'source-object) 1727 the-source) 1728 (equal? (((inspect/object proc-n) 'code) 'source-object) 1729 the-source) 1730 (equal? ((((inspect/object proc-i) 'code) 'source) 'value) 1731 '(lambda (x) x)) 1732 (equal? (((inspect/object proc-n) 'code) 'source) 1733 #f) 1734) 1735 1736(mat strip-fasl-file 1737 (error? 1738 (fasl-strip-options ratfink profile-source)) 1739 (error? ; not a string 1740 (strip-fasl-file (fasl-strip-options profile-source) "testfile.so" (fasl-strip-options profile-source))) 1741 (error? ; not a string 1742 (strip-fasl-file "testfile.so" (fasl-strip-options profile-source) (fasl-strip-options profile-source))) 1743 (error? ; not a fasl-strip-options object 1744 (strip-fasl-file "testfile.so" "testfile.so" "testfile.so")) 1745 (enum-set? (fasl-strip-options)) 1746 (enum-set? (fasl-strip-options inspector-source)) 1747 (enum-set? (fasl-strip-options inspector-source compile-time-information)) 1748 (begin 1749 (define object-file-size 1750 (lambda (path) 1751 (bytevector-length (call-with-port (open-file-input-port path (file-options compressed)) get-bytevector-all)))) 1752 (define strip-and-check 1753 (lambda (in out options) 1754 (let ([n (object-file-size in)]) 1755 (strip-fasl-file in out options) 1756 (< (object-file-size out) n)))) 1757 #t) 1758 1759 ; plain libraries 1760 (begin 1761 (with-output-to-file "testfile-sff-1a.ss" 1762 (lambda () 1763 (pretty-print 1764 '(library (testfile-sff-1a) 1765 (export a x) 1766 (import (chezscheme)) 1767 (define-syntax a (identifier-syntax (x 5))) 1768 (define x (lambda (n) (if (= n 0) 1 (* n (x (- n 1))))))))) 1769 'replace) 1770 (with-output-to-file "testfile-sff-1b.ss" 1771 (lambda () 1772 (pretty-print 1773 '(library (testfile-sff-1b) 1774 (export b y) 1775 (import (chezscheme) (testfile-sff-1a)) 1776 (define-syntax b (syntax-rules () [(_ k) (k y)])) 1777 (define y (x 4))))) 1778 'replace) 1779 (with-output-to-file "testfile-sff-1c.ss" 1780 (lambda () 1781 (pretty-print '(define preexisting-entries (length (profile-dump)))) 1782 (pretty-print '(eval-when (compile) (import (add-prefix (testfile-sff-1a) sff-1a-)))) 1783 (pretty-print '(eval-when (compile) (import (add-prefix (testfile-sff-1b) sff-1b-)))) 1784 (pretty-print '(pretty-print (list (sff-1a-x 3) sff-1b-y))) 1785 (pretty-print '(pretty-print (not (((inspect/object sff-1a-x) 'code) 'source)))) 1786 (pretty-print '(pretty-print (= (length (profile-dump)) preexisting-entries)))) 1787 'replace) 1788 (delete-file "testfile-sff-1a.so") 1789 (delete-file "testfile-sff-1b.so") 1790 (delete-file "testfile-sff-1c.so") 1791 (separate-compile 1792 '(lambda (x) 1793 (parameterize ([generate-inspector-information #t] 1794 [compile-profile #t] 1795 [compile-imported-libraries #t]) 1796 (compile-file x))) 1797 'sff-1c) 1798 #t) 1799 (begin 1800 (define (go) 1801 (separate-eval 1802 '(define preexisting-entries 1803 (with-exception-handler 1804 (lambda (c) (unless (warning? c) (raise-continuable c))) 1805 (lambda () (length (profile-dump-list))))) 1806 '(import (testfile-sff-1a)) 1807 '(import (testfile-sff-1b)) 1808 '(define-syntax so? 1809 (lambda (x) 1810 (syntax-case x () 1811 [(_ q) (and (syntax->annotation #'q) #t)]))) 1812 '(list a (b so?) (x 3) y) 1813 '(not (((inspect/object x) 'code) 'source)) 1814 '(define all-entries 1815 (with-exception-handler 1816 (lambda (c) (unless (warning? c) (raise-continuable c))) 1817 (lambda () (length (profile-dump-list))))) 1818 '(= all-entries preexisting-entries))) 1819 #t) 1820 (equal? 1821 (go) 1822 "(120 #t 6 24)\n#f\n#f\n") 1823 (strip-and-check "testfile-sff-1a.so" "testfile-sff-1a.so" 1824 (fasl-strip-options inspector-source)) 1825 (strip-and-check "testfile-sff-1b.so" "testfile-sff-1b.so" 1826 (fasl-strip-options inspector-source)) 1827 (equal? 1828 (go) 1829 "(120 #t 6 24)\n#t\n#f\n") 1830 (strip-and-check "testfile-sff-1a.so" "testfile-sff-1a.so" 1831 (fasl-strip-options profile-source)) 1832 (strip-and-check "testfile-sff-1b.so" "testfile-sff-1b.so" 1833 (fasl-strip-options profile-source)) 1834 (equal? 1835 (go) 1836 "(120 #t 6 24)\n#t\n#t\n") 1837 (strip-and-check "testfile-sff-1a.so" "testfile-sff-1a.so" 1838 (fasl-strip-options source-annotations)) 1839 (strip-and-check "testfile-sff-1b.so" "testfile-sff-1b.so" 1840 (fasl-strip-options source-annotations)) 1841 (equal? 1842 (go) 1843 "(120 #f 6 24)\n#t\n#t\n") 1844 (strip-and-check "testfile-sff-1a.so" "testfile-sff-1a.so" 1845 (fasl-strip-options compile-time-information)) 1846 (strip-and-check "testfile-sff-1b.so" "testfile-sff-1b.so" 1847 (fasl-strip-options compile-time-information)) 1848 (strip-and-check "testfile-sff-1c.so" "testfile-sff-1c.so" 1849 (fasl-strip-options profile-source)) 1850 (equal? 1851 (separate-eval 1852 '(guard (c [else (display-condition c) (newline) #t]) (eval '(import (testfile-sff-1b)))) 1853 '(guard (c [else (display-condition c) (newline) #t]) (eval '(import (testfile-sff-1a)))) 1854 '(expand 'a) 1855 '(expand 'b) 1856 '(load "testfile-sff-1c.so") 1857 '(guard (c [else (display-condition c) (newline) #t]) (eval '(import (testfile-sff-1b))))) 1858 "Exception: loading testfile-sff-1b.so did not define library (testfile-sff-1b)\n#t\n\ 1859 Exception: loading testfile-sff-1a.so did not define library (testfile-sff-1a)\n#t\n\ 1860 a\nb\n\ 1861 (6 24)\n#t\n#t\n\ 1862 Exception: loading testfile-sff-1b.so did not define compile-time information for library (testfile-sff-1b)\n#t\n\ 1863 ") 1864 1865 ; scripts 1866 (begin 1867 (with-output-to-file "testfile-sff.ss" 1868 (lambda () 1869 (printf "#! ~a --script\n" *scheme*) 1870 (pretty-print '(define (hello) (import (chezscheme)) (printf "hello\n"))) 1871 (pretty-print '(hello))) 1872 'replace) 1873 (parameterize ([generate-inspector-information #t]) 1874 (compile-script "testfile-sff")) 1875 #t) 1876 (strip-and-check "testfile-sff.so" "testfile-sff-stripped.so" 1877 (fasl-strip-options inspector-source)) 1878 (equal? 1879 (separate-eval 1880 '(load "testfile-sff.so") 1881 '(and (((inspect/object hello) 'code) 'source) #t)) 1882 "hello\n#t\n") 1883 (equal? 1884 (separate-eval 1885 '(load "testfile-sff-stripped.so") 1886 '(and (((inspect/object hello) 'code) 'source) #t)) 1887 "hello\n#f\n") 1888 (equal? 1889 (run-script "./testfile-sff.so") 1890 "hello\n") 1891 (equal? 1892 (run-script "./testfile-sff-stripped.so") 1893 "hello\n") 1894 1895 ; non-library compile-time-information 1896 (begin 1897 (with-output-to-file "testfile-sff-3.ss" 1898 (lambda () 1899 (pretty-print '(define cons vector)) 1900 (pretty-print '(define-syntax + (identifier-syntax -)))) 1901 'replace) 1902 (separate-compile 'sff-3) 1903 (define $orig-size (object-file-size "testfile-sff-3.so")) 1904 #t) 1905 (equal? 1906 (separate-eval 1907 '(load "testfile-sff-3.so") 1908 '(cons 3 4) 1909 '(+ 3 4)) 1910 "#(3 4)\n-1\n") 1911 (strip-and-check "testfile-sff-3.so" "testfile-sff-3.so" 1912 (fasl-strip-options compile-time-information)) 1913 (< (object-file-size "testfile-sff-3.so") $orig-size) 1914 (equal? 1915 (separate-eval 1916 '(load "testfile-sff-3.so") 1917 '(cons 3 4) 1918 '(+ 3 4)) 1919 "(3 . 4)\n7\n") 1920 (let ([n (object-file-size "testfile-sff-3.so")]) 1921 (strip-fasl-file "testfile-sff-3.so" "testfile-sff-3.so" 1922 (fasl-strip-options compile-time-information)) 1923 (= (object-file-size "testfile-sff-3.so") n)) 1924 (begin 1925 (mkfile "testfile-sff-4.ss" 1926 '(library (testfile-sff-4) (export a b c) (import (chezscheme)) 1927 (define-syntax a (identifier-syntax 12)) 1928 (define b 13) 1929 (meta define c 14))) 1930 (mkfile "testfile-sff-4p.ss" 1931 '(import (chezscheme) (testfile-sff-4)) 1932 '(write b)) 1933 (separate-compile 1934 '(lambda (x) (parameterize ([compile-imported-libraries #t]) (compile-program x))) 1935 'sff-4p) 1936 #t) 1937 (equal? 1938 (separate-eval 1939 '(let () 1940 (import (testfile-sff-4)) 1941 (define-syntax cc (lambda (x) c)) 1942 (printf "a = ~s, b = ~s, c = ~s\n" a b cc))) 1943 "a = 12, b = 13, c = 14\n") 1944 (equal? 1945 (separate-eval 1946 '(let ([x (with-output-to-string (lambda () (load-program "testfile-sff-4p.so")))]) 1947 (printf "b = ~a, a = ~s\n" x (eval 'a (environment '(testfile-sff-4)))))) 1948 "b = 13, a = 12\n") 1949 (begin 1950 (strip-fasl-file "testfile-sff-4.so" "testfile-sff-4.so" 1951 (fasl-strip-options compile-time-information)) 1952 #t) 1953 (error? ; no compile-time info 1954 (separate-eval 1955 '(let () 1956 (import (testfile-sff-4)) 1957 (list a b)))) 1958 (error? ; no compile-time info 1959 (separate-eval 1960 '(let ([x (with-output-to-string (lambda () (load-program "testfile-sff-4p.so")))]) 1961 (printf "b = ~a, a = ~s\n" x (eval 'a (environment '(testfile-sff-4))))))) 1962 (error? ; no compile-time info 1963 (separate-eval 1964 '(let ([x (with-output-to-string (lambda () (load-program "testfile-sff-4p.so")))]) 1965 (printf "b = ~a, a = ~s\n" x (eval '(let () (import (testfile-sff-4)) a)))))) 1966 (error? ; no compile-time info 1967 (separate-eval 1968 '(parameterize ([import-notify #t]) 1969 (let ([x (with-output-to-string (lambda () (load-program "testfile-sff-4p.so")))]) 1970 (printf "b = ~a, a = ~s\n" x (eval '(let () (import (testfile-sff-4)) a))))))) 1971) 1972 1973(mat $fasl-file-equal? 1974 (let ([fn (format "~a/fatfib.ss" *examples-directory*)]) 1975 (parameterize ([generate-inspector-information #t]) 1976 (compile-file fn "testfile-fatfib1.so")) 1977 (parameterize ([generate-inspector-information #t]) 1978 (compile-file fn "testfile-fatfib2.so")) 1979 (parameterize ([generate-inspector-information #f]) 1980 (compile-file fn "testfile-fatfib3.so")) 1981 #t) 1982 (error? ; not a string 1983 (#%$fasl-file-equal? 'testfile-fatfib1.so "testfile-fatfib2.so")) 1984 (error? ; not a string 1985 (#%$fasl-file-equal? 'testfile-fatfib1.so "testfile-fatfib2.so" #t)) 1986 (error? ; not a string 1987 (#%$fasl-file-equal? "testfile-fatfib1.so" 13.4)) 1988 (error? ; not a string 1989 (#%$fasl-file-equal? "testfile-fatfib1.so" 13.4 #f)) 1990 (error? ; file doesn't exist 1991 (#%$fasl-file-equal? "testfile-fatfib1.so" "probably-does-not-exist")) 1992 (error? ; file doesn't exist 1993 (#%$fasl-file-equal? "testfile-fatfib1.so" "probably-does-not-exist" #f)) 1994 (error? ; file doesn't exist 1995 (#%$fasl-file-equal? "probably-does-not-exist" "testfile-fatfib2.so")) 1996 (error? ; file doesn't exist 1997 (#%$fasl-file-equal? "probably-does-not-exist" "testfile-fatfib2.so" #t)) 1998 (#%$fasl-file-equal? "testfile-fatfib1.so" "testfile-fatfib2.so") 1999 (not (#%$fasl-file-equal? "testfile-fatfib1.so" "testfile-fatfib3.so")) 2000 (error? (#%$fasl-file-equal? "testfile-fatfib1.so" "testfile-fatfib3.so" #t)) 2001) 2002 2003(mat vfasl 2004 (begin 2005 (define-record-type vfasl-demo 2006 (fields x y) 2007 (nongenerative #{vfasl-demo pfwhk286n2j894o33awcq9er4-0})) 2008 (define vfasl-content (list 1 1/2 3.0 4+5i 6.0+7.0i 2009 "apple" 'banana 2010 (make-vfasl-demo 10 "11") 2011 (vector 1 'two "three") 2012 (stencil-vector 30 'one 2.0 0+3i "four") 2013 (box 88) 2014 "" '#() '#vu8() (make-fxvector 0) (make-flvector 0) 2015 (string->immutable-string "") (vector->immutable-vector '#()) 2016 (bytevector->immutable-bytevector '#vu8()))) 2017 (define (same-vfasl-content? v) 2018 (andmap (lambda (a b) 2019 (or (eqv? a b) 2020 (and (or (and (string? a) 2021 (positive? (string-length a))) 2022 (and (vector? a) 2023 (positive? (vector-length a))) 2024 (box? a) 2025 (stencil-vector? a)) 2026 (equal? a b)) 2027 (and (vfasl-demo? a) 2028 (vfasl-demo? b) 2029 (equal? (vfasl-demo-x a) 2030 (vfasl-demo-x b)) 2031 (equal? (vfasl-demo-y a) 2032 (vfasl-demo-y b))) 2033 (begin 2034 (printf "~s ~s\n" a b) 2035 #f))) 2036 vfasl-content 2037 v)) 2038 (compile-to-file (list `(define (vfasled) ',vfasl-content) 2039 `(define (get-vfasled) vfasled) 2040 `(define (call-vfasled) (vfasled))) 2041 "testfile-fasl.so") 2042 (vfasl-convert-file "testfile-fasl.so" "testfile-vfasl.so" #f) 2043 (load "testfile-vfasl.so") 2044 #t) 2045 2046 (same-vfasl-content? (vfasled)) 2047 (eq? vfasled (get-vfasled)) 2048 (eq? (vfasled) (call-vfasled))) 2049 2050(mat cost-center 2051 (error? ; wrong number of arguments 2052 (make-cost-center 'foo)) 2053 2054 (error? ; foo is not a cost center 2055 (with-cost-center 'foo (lambda () 5))) 2056 2057 (error? ; bar is not a procedure 2058 (with-cost-center (make-cost-center) 'bar)) 2059 2060 (error? ; 5 is not a cost center 2061 (cost-center-instruction-count 5)) 2062 2063 (error? ; "test" is not a cost center 2064 (cost-center-allocation-count "test")) 2065 2066 (error? ; 4.7 is not a cost center 2067 (cost-center-time 4.7)) 2068 2069 (error? ; #\c is not a cost center 2070 (reset-cost-center! #\c)) 2071 2072 (let ([cc (make-cost-center)]) 2073 (cost-center? cc)) 2074 2075 ;;; instruction cost center tests 2076 ((lambda (x) 2077 (<= 5 x 50)) 2078 (let ([cc (make-cost-center)]) 2079 (with-cost-center cc 2080 (lambda () 2081 (parameterize ([generate-instruction-counts #t] 2082 [compile-interpret-simple #f] 2083 [enable-cp0 #f]) 2084 (compile '(let ([p (cons 'a 'b)]) (car p)))))) 2085 (cost-center-instruction-count cc))) 2086 2087 (begin 2088 (define $cc-sum-1 2089 (parameterize ([generate-instruction-counts #t]) 2090 (compile 2091 '(lambda (ls) 2092 (let f ([ls ls]) 2093 (if (null? ls) 2094 0 2095 (+ (car ls) (f (cdr ls))))))))) 2096 #t) 2097 2098 ((lambda (x) 2099 (<= 100 x 1000)) 2100 (let ([cc (make-cost-center)]) 2101 (with-cost-center cc (lambda () ($cc-sum-1 (iota 10)))) 2102 (cost-center-instruction-count cc))) 2103 2104 ((lambda (x) 2105 (<= 1000 x 10000)) 2106 (let ([cc (make-cost-center)]) 2107 (with-cost-center cc (lambda () ($cc-sum-1 (iota 100)))) 2108 (cost-center-instruction-count cc))) 2109 2110 (begin 2111 (define $cc-1 (make-cost-center)) 2112 (define $cc-sum-2 2113 (parameterize ([generate-instruction-counts #t]) 2114 (compile 2115 '(lambda (ls) 2116 (let f ([ls ls]) 2117 (with-cost-center $cc-1 2118 (lambda () 2119 (if (null? ls) 2120 0 2121 (+ (car ls) (f (cdr ls))))))))))) 2122 #t) 2123 2124 ((lambda (x) 2125 (<= 100 x 1500)) 2126 (begin 2127 ($cc-sum-2 (iota 10)) 2128 (cost-center-instruction-count $cc-1))) 2129 2130 (begin 2131 (reset-cost-center! $cc-1) 2132 #t) 2133 2134 ((lambda (x) 2135 (<= 1000 x 15000)) 2136 (begin 2137 ($cc-sum-2 (iota 100)) 2138 (cost-center-instruction-count $cc-1))) 2139 2140 (begin 2141 (reset-cost-center! $cc-1) 2142 #t) 2143 2144 (let ([cc (make-cost-center)]) 2145 (with-cost-center cc (lambda () ($cc-sum-2 (iota 10)))) 2146 (<= (cost-center-instruction-count $cc-1) (cost-center-instruction-count cc))) 2147 2148 (begin 2149 (define-syntax when-threaded 2150 (lambda (x) 2151 (syntax-case x () 2152 [(_ e0 e1 ...) 2153 (if (threaded?) 2154 #'(begin e0 e1 ...) 2155 #'(begin #t))]))) 2156 #t) 2157 2158 (when-threaded 2159 ; copied from thread.ms 2160 (begin 2161 (define $threads (foreign-procedure "(cs)threads" () scheme-object)) 2162 (define $nthreads 1) 2163 (define $yield 2164 (let ([t (make-time 'time-duration 1000 0)]) 2165 (lambda () (sleep t)))) 2166 (define $thread-check 2167 (lambda () 2168 (let loop ([n 10] [nt (length ($threads))]) 2169 (cond 2170 [(<= nt $nthreads) 2171 (set! $nthreads nt) 2172 (collect)] 2173 [else 2174 ($yield) 2175 (let* ([ls ($threads)] [nnt (length ls)]) 2176 (cond 2177 [(< nnt nt) (loop n nnt)] 2178 [(= n 0) 2179 (set! $nthreads nnt) 2180 (errorf #f "extra threads running ~s" ls)] 2181 [else (loop (- n 1) nnt)]))])) 2182 #t)) 2183 ($thread-check))) 2184 2185 (when-threaded 2186 ((lambda (x) 2187 (<= 200 x 2000)) 2188 (let ([cc (make-cost-center)] 2189 [finished #f] 2190 [finished-mutex (make-mutex)] 2191 [finished-condition (make-condition)]) 2192 (define sum-th 2193 (lambda () 2194 (with-cost-center cc (lambda () ($cc-sum-1 (iota 10)))) 2195 (with-mutex finished-mutex 2196 (if finished 2197 (condition-signal finished-condition) 2198 (set! finished #t))))) 2199 (with-mutex finished-mutex 2200 (fork-thread sum-th) 2201 (fork-thread sum-th) 2202 (condition-wait finished-condition finished-mutex)) 2203 (cost-center-instruction-count cc)))) 2204 2205 (when-threaded ($thread-check)) 2206 2207 (when-threaded 2208 (reset-cost-center! $cc-1) 2209 ((lambda (x) 2210 (<= 200 x 3000)) 2211 (let ([finished #f] 2212 [finished-mutex (make-mutex)] 2213 [finished-condition (make-condition)]) 2214 (define sum-th 2215 (lambda () 2216 ($cc-sum-2 (iota 10)) 2217 (with-mutex finished-mutex 2218 (if finished 2219 (condition-signal finished-condition) 2220 (set! finished #t))))) 2221 (with-mutex finished-mutex 2222 (fork-thread sum-th) 2223 (fork-thread sum-th) 2224 (condition-wait finished-condition finished-mutex)) 2225 (cost-center-instruction-count $cc-1)))) 2226 2227 (when-threaded ($thread-check)) 2228 2229 (when-threaded 2230 (reset-cost-center! $cc-1) 2231 (let ([cc (make-cost-center)] 2232 [finished #f] 2233 [finished-mutex (make-mutex)] 2234 [finished-condition (make-condition)]) 2235 (define sum-th 2236 (lambda () 2237 (with-cost-center cc (lambda () ($cc-sum-2 (iota 10)))) 2238 (with-mutex finished-mutex 2239 (if finished 2240 (condition-signal finished-condition) 2241 (set! finished #t))))) 2242 (with-mutex finished-mutex 2243 (fork-thread sum-th) 2244 (fork-thread sum-th) 2245 (condition-wait finished-condition finished-mutex)) 2246 (<= (cost-center-instruction-count $cc-1) 2247 (cost-center-instruction-count cc)))) 2248 2249 (when-threaded ($thread-check)) 2250 2251 (begin 2252 (define $cc-fibonacci 2253 (let ([fib 2254 (parameterize ([generate-instruction-counts #t]) 2255 (compile 2256 '(rec fib 2257 (lambda (i) 2258 (cond 2259 [(= i 0) 0] 2260 [(= i 1) 1] 2261 [else (+ (fib (- i 1)) 2262 (fib (- i 2)))])))))]) 2263 (lambda (n) (with-cost-center $cc-1 (lambda () (fib n)))))) 2264 #t) 2265 2266 (let ([normal-count (begin 2267 (reset-cost-center! $cc-1) 2268 ($cc-fibonacci 10) 2269 (cost-center-instruction-count $cc-1))] 2270 [eng-count (begin 2271 (reset-cost-center! $cc-1) 2272 (let f ([eng (make-engine (lambda () ($cc-fibonacci 10)))]) 2273 (eng 50 (lambda args (cost-center-instruction-count $cc-1)) f)))]) 2274 ; range because when running in an engine the trap check might 2275 ; be taken, and it will slightly increase the instruction count 2276 (<= normal-count eng-count (+ normal-count 100))) 2277 2278 ;;; allocation cost center tests 2279 (eqv? 2280 (case (fixnum-width) 2281 [(30) 24] 2282 [(61) 48]) 2283 (let ([cc (make-cost-center)]) 2284 (with-cost-center cc 2285 (lambda () 2286 (parameterize ([generate-allocation-counts #t] 2287 [compile-interpret-simple #f]) 2288 (compile '(#%list 'a 'b 'c))))) 2289 (cost-center-allocation-count cc))) 2290 2291 ((lambda (count) ; range for rand call done to test variable alloc case and 64-bit words 2292 (<= 16 count 120)) 2293 (let ([cc (make-cost-center)]) 2294 (with-cost-center cc 2295 (lambda () 2296 (parameterize ([generate-allocation-counts #t] [compile-interpret-simple #f]) 2297 (compile `(let ([x (fx+ 3 (random 10))]) 2298 (#3%make-vector x)))))) 2299 (cost-center-allocation-count cc))) 2300 2301 (begin 2302 (define $cc-reverse-1 2303 (parameterize ([generate-allocation-counts #t]) 2304 (compile 2305 '(lambda (ls) 2306 (let f ([ls ls] [rls '()]) 2307 (if (null? ls) 2308 rls 2309 (f (cdr ls) (#%cons (car ls) rls)))))))) 2310 #t) 2311 2312 (eqv? 2313 (case (fixnum-width) 2314 [(30) 80] 2315 [(61) 160]) 2316 (let ([cc (make-cost-center)]) 2317 (with-cost-center cc (lambda () ($cc-reverse-1 (make-list 10)))) 2318 (cost-center-allocation-count cc))) 2319 2320 (eqv? 2321 (case (fixnum-width) 2322 [(30) 800] 2323 [(61) 1600]) 2324 (let ([cc (make-cost-center)]) 2325 (with-cost-center cc (lambda () ($cc-reverse-1 (make-list 100)))) 2326 (cost-center-allocation-count cc))) 2327 2328 (begin 2329 (define $cc-2 (make-cost-center)) 2330 (define $cc-reverse-2 2331 (parameterize ([generate-allocation-counts #t]) 2332 (compile 2333 '(lambda (ls) 2334 (let f ([ls ls] [rls '()]) 2335 (with-cost-center $cc-2 2336 (lambda () 2337 (if (null? ls) 2338 rls 2339 (f (cdr ls) (#%cons (car ls) rls)))))))))) 2340 #t) 2341 2342 ((lambda (x) ; wide range to accommodate both 4-byte and 8-byte words 2343 (<= 80 x 480)) 2344 (begin 2345 ($cc-reverse-2 (make-list 10)) 2346 (cost-center-allocation-count $cc-2))) 2347 2348 (begin 2349 (reset-cost-center! $cc-2) 2350 #t) 2351 2352 ((lambda (x) ; wide range to accommodate both 4-byte and 8-byte words 2353 (<= 800 x 4800)) 2354 (begin 2355 ($cc-reverse-2 (make-list 100)) 2356 (cost-center-allocation-count $cc-2))) 2357 2358 (begin 2359 (reset-cost-center! $cc-2) 2360 #t) 2361 2362 (let ([cc (make-cost-center)]) 2363 (with-cost-center cc (lambda () ($cc-reverse-2 (make-list 10)))) 2364 (<= (cost-center-allocation-count $cc-2) (cost-center-allocation-count cc))) 2365 2366 (begin 2367 (define $cc-reverse-3 2368 (let ([rev (parameterize ([generate-allocation-counts #t]) 2369 (compile 2370 '(rec rev 2371 (lambda (ls rls) 2372 (if (null? ls) 2373 rls 2374 (rev (cdr ls) (#%cons (car ls) rls)))))))]) 2375 (lambda (ls) 2376 (with-cost-center $cc-2 (lambda () (rev ls '())))))) 2377 #t) 2378 2379 (eqv? 2380 (begin 2381 (reset-cost-center! $cc-2) 2382 ($cc-reverse-3 (iota 10)) 2383 (cost-center-allocation-count $cc-2)) 2384 (begin 2385 (reset-cost-center! $cc-2) 2386 (let f ([eng (make-engine (lambda () ($cc-reverse-3 (iota 10))))]) 2387 (eng 10 (lambda args (cost-center-allocation-count $cc-2)) f)))) 2388 2389 (when-threaded 2390 (eqv? 2391 (case (fixnum-width) 2392 [(30) 160] 2393 [(61) 320]) 2394 (let ([cc (make-cost-center)] 2395 [finished #f] 2396 [finished-mutex (make-mutex)] 2397 [finished-condition (make-condition)]) 2398 (define reverse-th 2399 (lambda () 2400 (with-cost-center cc (lambda () ($cc-reverse-1 (iota 10)))) 2401 (with-mutex finished-mutex 2402 (if finished 2403 (condition-signal finished-condition) 2404 (set! finished #t))))) 2405 (with-mutex finished-mutex 2406 (fork-thread reverse-th) 2407 (fork-thread reverse-th) 2408 (condition-wait finished-condition finished-mutex)) 2409 (cost-center-allocation-count cc)))) 2410 2411 (when-threaded ($thread-check)) 2412 2413 (when-threaded 2414 (reset-cost-center! $cc-2) 2415 ((lambda (x) ; wide range to accommodate both 4-byte and 8-byte words 2416 (<= 160 x 960)) 2417 (let ([finished #f] 2418 [finished-mutex (make-mutex)] 2419 [finished-condition (make-condition)]) 2420 (define reverse-th 2421 (lambda () 2422 ($cc-reverse-2 (iota 10)) 2423 (with-mutex finished-mutex 2424 (if finished 2425 (condition-signal finished-condition) 2426 (set! finished #t))))) 2427 (with-mutex finished-mutex 2428 (fork-thread reverse-th) 2429 (fork-thread reverse-th) 2430 (condition-wait finished-condition finished-mutex)) 2431 (cost-center-allocation-count $cc-2)))) 2432 2433 (when-threaded ($thread-check)) 2434 2435 (when-threaded 2436 (reset-cost-center! $cc-2) 2437 (let ([cc (make-cost-center)] 2438 [finished #f] 2439 [finished-mutex (make-mutex)] 2440 [finished-condition (make-condition)]) 2441 (define reverse-th 2442 (lambda () 2443 (with-cost-center cc (lambda () ($cc-reverse-2 (iota 10)))) 2444 (with-mutex finished-mutex 2445 (if finished 2446 (condition-signal finished-condition) 2447 (set! finished #t))))) 2448 (with-mutex finished-mutex 2449 (fork-thread reverse-th) 2450 (fork-thread reverse-th) 2451 (condition-wait finished-condition finished-mutex)) 2452 (<= (cost-center-instruction-count $cc-2) 2453 (cost-center-instruction-count cc)))) 2454 2455 (when-threaded ($thread-check)) 2456 2457 ;;; instruction with allocation cost center tests 2458 ((lambda (x) 2459 (<= 10 x 50)) 2460 (let ([cc (make-cost-center)]) 2461 (with-cost-center cc 2462 (lambda () 2463 (parameterize ([generate-allocation-counts #t] 2464 [generate-instruction-counts #t] 2465 [compile-interpret-simple #f] 2466 [enable-cp0 #f]) 2467 (compile '(let ([p (cons 'a 'b)]) (car p)))))) 2468 (cost-center-instruction-count cc))) 2469 2470 (begin 2471 (define $cc-sum-1 2472 (parameterize ([generate-allocation-counts #t] 2473 [generate-instruction-counts #t]) 2474 (compile 2475 '(lambda (ls) 2476 (let f ([ls ls]) 2477 (if (null? ls) 2478 0 2479 (+ (car ls) (f (cdr ls))))))))) 2480 #t) 2481 2482 ((lambda (x) 2483 (<= 100 x 1000)) 2484 (let ([cc (make-cost-center)]) 2485 (with-cost-center cc (lambda () ($cc-sum-1 (iota 10)))) 2486 (cost-center-instruction-count cc))) 2487 2488 ((lambda (x) 2489 (<= 1000 x 10000)) 2490 (let ([cc (make-cost-center)]) 2491 (with-cost-center cc (lambda () ($cc-sum-1 (iota 100)))) 2492 (cost-center-instruction-count cc))) 2493 2494 (begin 2495 (define $cc-1 (make-cost-center)) 2496 (define $cc-sum-2 2497 (parameterize ([generate-allocation-counts #t] 2498 [generate-instruction-counts #t]) 2499 (compile 2500 '(lambda (ls) 2501 (let f ([ls ls]) 2502 (with-cost-center $cc-1 2503 (lambda () 2504 (if (null? ls) 2505 0 2506 (+ (car ls) (f (cdr ls))))))))))) 2507 #t) 2508 2509 ((lambda (x) 2510 (<= 100 x 1500)) 2511 (begin 2512 ($cc-sum-2 (iota 10)) 2513 (cost-center-instruction-count $cc-1))) 2514 2515 (begin 2516 (reset-cost-center! $cc-1) 2517 #t) 2518 2519 ((lambda (x) 2520 (<= 1000 x 15000)) 2521 (begin 2522 ($cc-sum-2 (iota 100)) 2523 (cost-center-instruction-count $cc-1))) 2524 2525 (begin 2526 (reset-cost-center! $cc-1) 2527 #t) 2528 2529 (let ([cc (make-cost-center)]) 2530 (with-cost-center cc (lambda () ($cc-sum-2 (iota 10)))) 2531 (<= (cost-center-instruction-count $cc-1) (cost-center-instruction-count cc))) 2532 2533 ;; allocation with instruction counts 2534 (eqv? 2535 (case (fixnum-width) 2536 [(30) 24] 2537 [(61) 48]) 2538 (let ([cc (make-cost-center)]) 2539 (with-cost-center cc 2540 (lambda () 2541 (parameterize ([generate-allocation-counts #t] 2542 [generate-instruction-counts #t] 2543 [compile-interpret-simple #f]) 2544 (compile '(#%list 'a 'b 'c))))) 2545 (cost-center-allocation-count cc))) 2546 2547 (let ([x (fx+ 3 (random 10))]) 2548 ((lambda (count) ; range for padding on 32-bit and to accomadate 64-bit words 2549 (<= (fxsll (fx+ x 1) 2) count (fxsll (fx+ x 2) 3))) 2550 (let ([cc (make-cost-center)]) 2551 (with-cost-center cc 2552 (lambda () 2553 (parameterize ([generate-allocation-counts #t] 2554 [generate-instruction-counts #t] 2555 [compile-interpret-simple #f]) 2556 (compile `(#%make-vector ,x))))) 2557 (cost-center-allocation-count cc)))) 2558 2559 (begin 2560 (define $cc-reverse-1 2561 (parameterize ([generate-allocation-counts #t] 2562 [generate-instruction-counts #t]) 2563 (compile 2564 '(lambda (ls) 2565 (let f ([ls ls] [rls '()]) 2566 (if (null? ls) 2567 rls 2568 (f (cdr ls) (#%cons (car ls) rls)))))))) 2569 #t) 2570 2571 (eqv? 2572 (case (fixnum-width) 2573 [(30) 80] 2574 [(61) 160]) 2575 (let ([cc (make-cost-center)]) 2576 (with-cost-center cc (lambda () ($cc-reverse-1 (make-list 10)))) 2577 (cost-center-allocation-count cc))) 2578 2579 (eqv? 2580 (case (fixnum-width) 2581 [(30) 800] 2582 [(61) 1600]) 2583 (let ([cc (make-cost-center)]) 2584 (with-cost-center cc (lambda () ($cc-reverse-1 (make-list 100)))) 2585 (cost-center-allocation-count cc))) 2586 2587 (begin 2588 (define $cc-2 (make-cost-center)) 2589 (define $cc-reverse-2 2590 (parameterize ([generate-allocation-counts #t] 2591 [generate-instruction-counts #t]) 2592 (compile 2593 '(lambda (ls) 2594 (let f ([ls ls] [rls '()]) 2595 (with-cost-center $cc-2 2596 (lambda () 2597 (if (null? ls) 2598 rls 2599 (f (cdr ls) (#%cons (car ls) rls)))))))))) 2600 #t) 2601 2602 ((lambda (x) ; wide range to accommodate both 4-byte and 8-byte words 2603 (<= 80 x 480)) 2604 (begin 2605 ($cc-reverse-2 (make-list 10)) 2606 (cost-center-allocation-count $cc-2))) 2607 2608 (begin 2609 (reset-cost-center! $cc-2) 2610 #t) 2611 2612 ((lambda (x) ; wide range to accommodate both 4-byte and 8-byte words 2613 (<= 800 x 4800)) 2614 (begin 2615 ($cc-reverse-2 (make-list 100)) 2616 (cost-center-allocation-count $cc-2))) 2617 2618 (> (cost-center-allocation-count $cc-2) 0) 2619 (> (cost-center-instruction-count $cc-2) 0) 2620 2621 (begin 2622 (reset-cost-center! $cc-2) 2623 #t) 2624 2625 (fx= (cost-center-allocation-count $cc-2) 0) 2626 (fx= (cost-center-instruction-count $cc-2) 0) 2627 2628 (let ([cc (make-cost-center)]) 2629 (with-cost-center cc (lambda () ($cc-reverse-2 (make-list 10)))) 2630 (<= (cost-center-allocation-count $cc-2) (cost-center-allocation-count cc))) 2631 2632 (begin 2633 (define $fib (lambda (x) (if (< x 2) 1 (+ ($fib (- x 1)) ($fib (- x 2)))))) 2634 #t) 2635 2636 ;; timing information (no instrumentation needed) 2637 ((lambda (x) 2638 (and (time<? (make-time 'time-duration 0 0) x) 2639 (time<? x (make-time 'time-duration 0 10)))) 2640 (let ([cc (make-cost-center)]) 2641 (with-cost-center #t cc 2642 (lambda () 2643 (let ([t0 (current-time 'time-thread)]) 2644 (let f () 2645 (when (time=? (current-time 'time-thread) t0) 2646 ($fib 10) 2647 (f)))))) 2648 (cost-center-time cc))) 2649 2650 (let ([cc1 (make-cost-center)] [cc2 (make-cost-center)]) 2651 (with-cost-center #t cc1 2652 (lambda () 2653 (let f ([n 10]) 2654 (with-cost-center #t cc2 2655 (lambda () 2656 (cond 2657 [(= n 0) 1] 2658 [(= n 1) 1] 2659 [else (+ (f (- n 1)) (f (- n 2)))])))))) 2660 (time<=? (cost-center-time cc2) (cost-center-time cc1))) 2661 2662 (begin 2663 (define $cc-3 (make-cost-center)) 2664 (define $cc-fib 2665 (parameterize ([generate-allocation-counts #t] 2666 [generate-instruction-counts #t]) 2667 (compile 2668 '(let () 2669 (define (n->peano n) 2670 (if (zero? n) 2671 '() 2672 (cons 'succ (n->peano (- n 1))))) 2673 (define peano->n length) 2674 (define (peano-sub1 n) 2675 (if (null? n) 2676 (error 'peano-sub "cannot subtract 1 from 0") 2677 (cdr n))) 2678 (define peano-zero '()) 2679 (define (peano-add1 n) (#%cons 'succ n)) 2680 (define (peano+ n1 n2) 2681 (if (eq? n1 peano-zero) 2682 n2 2683 (peano-add1 (peano+ (peano-sub1 n1) n2)))) 2684 (lambda (n) 2685 (with-cost-center #t $cc-3 2686 (lambda () 2687 (peano->n 2688 (let f ([n (n->peano n)]) 2689 (cond 2690 [(equal? n peano-zero) (peano-add1 peano-zero)] 2691 [(equal? n (peano-add1 peano-zero)) (peano-add1 peano-zero)] 2692 [else 2693 (let ([n (peano-sub1 n)]) 2694 (peano+ (f n) (f (peano-sub1 n))))])))))))))) 2695 #t) 2696 2697 (fx= (cost-center-instruction-count $cc-3) 0) 2698 (fx= (cost-center-allocation-count $cc-3) 0) 2699 (time=? (cost-center-time $cc-3) (make-time 'time-duration 0 0)) 2700 2701 ((lambda (x) 2702 (and (time<? (make-time 'time-duration 0 0) x) 2703 (or (time<? x (make-time 'time-duration 0 20)) 2704 (#%$enable-check-heap)))) 2705 (begin 2706 ($cc-fib 30) 2707 (cost-center-time $cc-3))) 2708 2709 (> (cost-center-instruction-count $cc-3) 0) 2710 (> (cost-center-allocation-count $cc-3) 0) 2711 (time>? (cost-center-time $cc-3) (make-time 'time-duration 0 0)) 2712 2713 (begin 2714 (reset-cost-center! $cc-3) 2715 #t) 2716 2717 (fx= (cost-center-instruction-count $cc-3) 0) 2718 (fx= (cost-center-allocation-count $cc-3) 0) 2719 (time=? (cost-center-time $cc-3) (make-time 'time-duration 0 0)) 2720) 2721 2722 2723 2724(mat lock-object 2725 (begin 2726 (define $locked-objects (foreign-procedure "(cs)locked_objects" () ptr)) 2727 #t) 2728 (let ([ls ($locked-objects)]) 2729 (unless (null? ls) (errorf #f "found locked objects ~s" ls)) 2730 #t) 2731 (let () 2732 (define-record user-event (x)) 2733 (do ([n 20 (- n 1)]) 2734 ((= n 0)) 2735 (for-each unlock-object 2736 (map (lambda (x) (lock-object x) x) 2737 (map make-user-event 2738 (make-list 10000))))) 2739 #t) 2740 (let ([ls ($locked-objects)]) 2741 (unless (null? ls) (errorf #f "found locked objects ~s" ls)) 2742 #t) 2743 (let () 2744 (define-record user-event (x)) 2745 (do ([n 20 (- n 1)]) 2746 ((= n 0)) 2747 (for-each unlock-object 2748 (map (lambda (x) 2749 (let ([x (case x 2750 [(0) (lambda () x)] 2751 [(1) (cons x x)] 2752 [(2) (vector x)] 2753 [(3) (vector x x)] 2754 [(4) (string #\a #\b)] 2755 [(5) (box (cons 3 4))] 2756 [(6) (/ 8 17)] 2757 [(7) (exact (sin 3.0))] 2758 [(8) (exact (sqrt -73.0))] 2759 [(9) (call/cc values)] 2760 [(10) (make-user-event x)])]) 2761 (lock-object x) 2762 x)) 2763 (map random (make-list 2000 11))))) 2764 #t) 2765 (let ([ls ($locked-objects)]) 2766 (unless (null? ls) (errorf #f "found locked objects ~s" ls)) 2767 #t) 2768 (eqv? 2769 (let () 2770 (define (pick ls) (list-ref ls (random (length ls)))) 2771 ; we don't pick then remq-first because the picked element may be 2772 ; an unlocked flonum and may be cloned into two copies by the 2773 ; collector between the pick and the remq-first 2774 (define (pick-rem ls) 2775 (let f ([ls ls] [i (random (length ls))]) 2776 (if (fx= i 0) 2777 (values (car ls) (cdr ls)) 2778 (let-values ([(x d) (f (cdr ls) (fx- i 1))]) 2779 (values x (cons (car ls) d)))))) 2780 (module (random-tree) 2781 (define leaves 2782 `(,(lambda () '()) 2783 ,(lambda () 0) 2784 ,(lambda () #f) 2785 ,(lambda () #t) 2786 ,(lambda () #\q) 2787 ,(lambda () (* 3.4 5)) 2788 ,(lambda () (* 15/16 5)) 2789 ,(lambda () (* 1+2i 5)) 2790 ,(lambda () (* 3.0-2.5i 5)) 2791 ,(lambda () (pick (oblist))) 2792 ,gensym 2793 ,(lambda () (make-string (random 10) (pick '(#\$ #\! #\*)))) 2794 )) 2795 (define nodes 2796 `(,(lambda (th) (cons (th) (th))) 2797 ,(lambda (th) (weak-cons (th) (th))) 2798 ,(lambda (th) (list->vector (map (lambda (x) (th)) (make-list (+ 1 (random 4)))))) 2799 ,(lambda (th) 2800 (define-record frob ((immutable x) (immutable y))) 2801 (record-reader 'frob1 (type-descriptor frob)) 2802 (make-frob (th) (th))) 2803 ,(lambda (th) 2804 (define-record frob ((immutable x) (mutable y))) 2805 (record-reader 'frob2 (type-descriptor frob)) 2806 (make-frob (th) (th))) 2807 ,(lambda (th) 2808 (define-record frob ((immutable x) (immutable integer-32 y))) 2809 (record-reader 'frob3 (type-descriptor frob)) 2810 (make-frob (th) (random 200000))) 2811 ,(lambda (th) 2812 (define-record frob ((immutable x) (mutable integer-32 y))) 2813 (record-reader 'frob4 (type-descriptor frob)) 2814 (make-frob (th) (random 200000))) 2815 ,(lambda (th) 2816 (let ([x (th)] [y (th)]) 2817 (let ([f (lambda () (cons x y))]) 2818 (values f (#%$closure-code f))))) 2819 ,(lambda (th) 2820 (let ([x (th)] [y (th)]) 2821 (call/cc 2822 (lambda (k) 2823 (call/cc (lambda (k1) (k k1))) 2824 (cons x y))))) 2825 )) 2826 (define random-tree 2827 (lambda (n) 2828 (let ([objects '()]) 2829 (let ([t (let f ([n n]) 2830 (let-values ([t* (if (= n 0) 2831 ((pick leaves)) 2832 ((pick nodes) (lambda () (f (- n 1)))))]) 2833 (set! objects (append t* objects)) 2834 (car t*)))]) 2835 objects))))) 2836 (define (chew n) 2837 (let f ([ls (make-list n)]) 2838 (if (< (length ls) 2) 2839 (random-tree 2) 2840 (append (f (cddr ls)) (f (cdr ls)))))) 2841 (define (randomize ls) 2842 (if (null? ls) 2843 '() 2844 (let-values ([(a d) (pick-rem ls)]) 2845 (cons a (randomize d))))) 2846 (define (split ls) 2847 (if (null? ls) 2848 (values '() '()) 2849 (let-values ([(a ls) (pick-rem ls)]) 2850 (let-values ([(ls1 ls2) (split ls)]) 2851 (if (= (random 2) 0) 2852 (values (cons a ls1) ls2) 2853 (values ls1 (cons a ls2))))))) 2854 (define (locktest) 2855 (define m 5) 2856 (let f ([n 100] [l0 '()] [l1 '()] [l2 '()]) 2857 (let ([l1addr (map #%$fxaddress l1)] [l2addr (map #%$fxaddress l2)]) 2858 (chew 15) 2859 (let ([bad (remq f 2860 (map (lambda (x a) (if (fx= (#%$fxaddress x) a) f x)) 2861 (append l1 l2) 2862 (append l1addr l2addr)))]) 2863 (unless (andmap flonum? bad) 2864 (errorf 'locktest "locked object address(es) changed for ~s" bad)))) 2865 (if (= n 0) 2866 (begin 2867 (for-each unlock-object l1) 2868 (for-each unlock-object l2) 2869 (for-each unlock-object l2) 2870 'yippee!) 2871 (let-values ([(l0drop l0keep) (split l0)] 2872 [(l1drop l1keep) (split l1)] 2873 [(l2drop l2keep) (split l2)]) 2874 (for-each unlock-object l1drop) 2875 (for-each unlock-object l2drop) 2876 (for-each unlock-object l2drop) 2877 (let-values ([(l0stay l0up) (split l0keep)] 2878 [(l1down l1up) (split l1keep)] 2879 [(l2down l2stay) (split l2keep)]) 2880 (for-each lock-object l0up) 2881 (for-each lock-object l1up) 2882 (for-each unlock-object l1down) 2883 (for-each unlock-object l2down) 2884 (f (- n 1) 2885 (randomize (append l0stay l1down)) 2886 (let ([l1new (random-tree m)]) 2887 (for-each lock-object l1new) 2888 (randomize (append l0up l2down l1new))) 2889 (randomize (append l1up l2stay)))))))) 2890 (locktest)) 2891 'yippee!) 2892 (let ([ls ($locked-objects)]) 2893 (unless (null? ls) (errorf #f "found locked objects ~s" ls)) 2894 #t) 2895 (eqv? 2896 (let () 2897 (define-record frob ((immutable x) (immutable y)) 2898 ([(immutable hash) (hash-frob x y)])) 2899 (define leaves 2900 `(,(lambda () '()) 2901 ,(lambda () 0) 2902 ,(lambda () #f) 2903 ,(lambda () #t) 2904 ,(lambda () #\q) 2905 ,(lambda () (* 3.4 5)) 2906 ,(lambda () (* 15/16 5)) 2907 ,(lambda () (* 1+2i 5)) 2908 ,(lambda () (* 3.0-2.5i 5)) 2909 ,(lambda () (pick (oblist))) 2910 ,gensym 2911 ,(lambda () (make-string (random 10) (pick '(#\$ #\! #\*)))) 2912 )) 2913 (define (hash-frob x y) (+ 13 (ash (hash x) 4) (* (hash y) 7))) 2914 (define (hash x) 2915 (case x 2916 [(()) 1] 2917 [(0) 2] 2918 [(#f) 3] 2919 [(#t) 4] 2920 [(#\q) 5] 2921 [(17.0) 6] 2922 [(75/16) 7] 2923 [(5+10i) 8] 2924 [(15.0-12.5i) 9] 2925 [else 2926 (cond 2927 [(gensym? x) (+ 10 (ash (hash-string (symbol->string x)) 4))] 2928 [(symbol? x) (+ 11 (ash (hash-string (symbol->string x)) 4))] 2929 [(string? x) (+ 12 (ash (hash-string x) 4))] 2930 [(frob? x) (hash-frob (frob-x x) (frob-y x))] 2931 [else (errorf 'hash "unexpected object ~s" x)])])) 2932 (define (hash-string s) 2933 (apply logxor (map char->integer (string->list s)))) 2934 (define (check-hash x) 2935 (let ([h (hash x)]) ; run regardless for error check 2936 (when (frob? x) 2937 (unless (= (hash x) (frob-hash x)) 2938 (errorf 'check-hash "hash mismatch for ~s" x))))) 2939 (define (pick ls) (list-ref ls (random (length ls)))) 2940 ; we don't pick then remq-first because the picked element may be 2941 ; an unlocked flonum and may be cloned into two copies by the 2942 ; collector between the pick and the remq-first 2943 (define (pick-rem ls) 2944 (let f ([ls ls] [i (random (length ls))]) 2945 (if (fx= i 0) 2946 (values (car ls) (cdr ls)) 2947 (let-values ([(x d) (f (cdr ls) (fx- i 1))]) 2948 (values x (cons (car ls) d)))))) 2949 (define random-tree 2950 (lambda (n) 2951 (let ([objects '()]) 2952 (let ([t (let f ([n n]) 2953 (let-values ([t* (if (= n 0) 2954 ((pick leaves)) 2955 (make-frob (f (- n 1)) (f (- n 1))))]) 2956 (set! objects (append t* objects)) 2957 (car t*)))]) 2958 objects)))) 2959 (define (chew n) 2960 (let f ([ls (make-list n)]) 2961 (if (< (length ls) 2) 2962 (random-tree 2) 2963 (append (f (cddr ls)) (f (cdr ls)))))) 2964 (define (randomize ls) 2965 (if (null? ls) 2966 '() 2967 (let-values ([(a d) (pick-rem ls)]) 2968 (cons a (randomize d))))) 2969 (define (split ls) 2970 (if (null? ls) 2971 (values '() '()) 2972 (let-values ([(a ls) (pick-rem ls)]) 2973 (let-values ([(ls1 ls2) (split ls)]) 2974 (if (= (random 2) 0) 2975 (values (cons a ls1) ls2) 2976 (values ls1 (cons a ls2))))))) 2977 (define (locktest) 2978 (define m 5) 2979 (let f ([n 100] [l0 '()] [l1 '()] [l2 '()]) 2980 (let ([l1addr (map #%$fxaddress l1)] [l2addr (map #%$fxaddress l2)]) 2981 (chew 15) 2982 (let ([bad (remq f 2983 (map (lambda (x a) (if (fx= (#%$fxaddress x) a) f x)) 2984 (append l1 l2) 2985 (append l1addr l2addr)))]) 2986 (unless (andmap flonum? bad) 2987 (errorf 'locktest "locked object address(es) changed for ~s" bad)))) 2988 (for-each check-hash l0) 2989 (for-each check-hash l1) 2990 (for-each check-hash l2) 2991 (if (= n 0) 2992 (begin 2993 (for-each unlock-object l1) 2994 (for-each unlock-object l2) 2995 (for-each unlock-object l2) 2996 'yippee!) 2997 (let-values ([(l0drop l0keep) (split l0)] 2998 [(l1drop l1keep) (split l1)] 2999 [(l2drop l2keep) (split l2)]) 3000 (for-each unlock-object l1drop) 3001 (for-each unlock-object l2drop) 3002 (for-each unlock-object l2drop) 3003 (let-values ([(l0stay l0up) (split l0keep)] 3004 [(l1down l1up) (split l1keep)] 3005 [(l2down l2stay) (split l2keep)]) 3006 (for-each lock-object l0up) 3007 (for-each lock-object l1up) 3008 (for-each unlock-object l1down) 3009 (for-each unlock-object l2down) 3010 (f (- n 1) 3011 (randomize (append l0stay l1down)) 3012 (let ([l1new (random-tree m)]) 3013 (for-each lock-object l1new) 3014 (randomize (append l0up l2down l1new))) 3015 (randomize (append l1up l2stay)))))))) 3016 (locktest)) 3017 'yippee!) 3018 (let ([ls ($locked-objects)]) 3019 (unless (null? ls) (errorf #f "found locked objects ~s" ls)) 3020 #t) 3021 (parameterize ([collect-request-handler void]) 3022 (define x (cons 3 4)) 3023 (lock-object x) 3024 (collect 1 1) ; should leave segment containing x with locked bit 3025 (set-cdr! x (cons 0 0)) ; should mark the card containing x in the segment dirty 3026 (collect 0 0) ; should crash if sweep_dirty doesn't ignore locked objects 3027 (unlock-object x) 3028 #t) 3029 (let ([ls ($locked-objects)]) 3030 (unless (null? ls) (errorf #f "found locked objects ~s" ls)) 3031 #t) 3032 ; shouldn't include immediates in locked-object lists 3033 (begin 3034 (lock-object -17) 3035 (lock-object #f) 3036 (lock-object #!eof) 3037 (lock-object #\newline) 3038 (let ([ls ($locked-objects)]) 3039 (unless (null? ls) (errorf #f "found locked objects ~s" ls)) 3040 #t)) 3041 ; cons should be static, and shouldn't include static objects in locked-object lists 3042 (begin 3043 (lock-object 'cons) 3044 (let ([ls ($locked-objects)]) 3045 (unless (null? ls) (errorf #f "found locked objects ~s" ls)) 3046 #t)) 3047 ; locked objects promoted to static generation are listed in the static-generation locked list 3048 ; so mutated locked objects are properly swept (and the cards they're in, which might contain 3049 ; random stuff, aren't) 3050 #;(parameterize ([collect-request-handler void]) 3051 (define x (cons 3 4)) 3052 (lock-object x) 3053 (collect (collect-maximum-generation) 'static) 3054 (let ([ls ($locked-objects)]) 3055 (unless (null? ls) (errorf #f "found locked objects ~s" ls)) 3056 #t)) 3057 3058 ;; Make sure a locked object that spans segments is appropriately 3059 ;; swept when it's modified to ceate a backpointer 3060 (let* ([N 100000] 3061 [v (make-vector N)]) 3062 (lock-object v) 3063 (collect 0) 3064 (let ([p (cons 1 2)]) 3065 (vector-set! v (sub1 N) p) 3066 (collect 0) 3067 (set-car! p 'yes) 3068 (unlock-object v) 3069 (equal? '(yes . 2) (vector-ref v (sub1 N))))) 3070 ) 3071 3072(mat eval-order 3073 (eqv? (call/cc (lambda (k) (0 (k 1)))) 1) 3074 (eqv? (let ([zero 0]) (call/cc (lambda (k) (zero (k 1))))) 1) 3075 (begin 3076 (define $notproc (cons 'not 'proc)) 3077 (not (procedure? $notproc))) 3078 (eqv? (call/cc (lambda (k) ($notproc (k 1)))) 1) 3079) 3080 3081 3082(define eval-test 3083 (lambda (s) 3084 (with-output-to-file "testfile.ss" 3085 (lambda () (display s)) 3086 'replace) 3087 (parameterize ([#%$suppress-primitive-inlining #f]) 3088 (load "testfile.ss" (lambda (x) (eval x)))) 3089 #t)) 3090(define load-test 3091 (lambda (s) 3092 (with-output-to-file "testfile.ss" 3093 (lambda () (display s)) 3094 'replace) 3095 (parameterize ([#%$suppress-primitive-inlining #f]) 3096 (load "testfile.ss")) 3097 #t)) 3098(define compile-test 3099 (lambda (s) 3100 (with-output-to-file "testfile.ss" 3101 (lambda () (display s)) 3102 'replace) 3103 (parameterize ([#%$suppress-primitive-inlining #f]) 3104 (compile-file "testfile.ss")) 3105 (load "testfile.so") 3106 #t)) 3107 3108(define-syntax error/warning-mat 3109 (syntax-rules () 3110 [(_ what string ...) 3111 (begin 3112 ; removed primitive argcnt warnings when no source is available 3113 ; to avoid warnings followed immediately by errors in the repl 3114 ; and warnings in run-time calls to eval 3115 #;(mat (what eval-warning) (warning? (eval-test string)) ...) 3116 (mat (what eval-error) (error? (eval-test string)) ...) 3117 (mat (what load-warning) (warning? (load-test string)) ...) 3118 (mat (what load-error) (error? (load-test string)) ...) 3119 (mat (what compile-warning) (warning? (compile-test string)) ...) 3120 (mat (what compile-error) (error? (compile-test string)) ...))])) 3121 3122(define-syntax error-mat 3123 (syntax-rules () 3124 [(_ what string ...) 3125 (begin 3126 (mat (what eval-error) (error? (eval-test string)) ...) 3127 (mat (what load-error) (error? (load-test string)) ...) 3128 (mat (what compile-error) (error? (compile-test string)) ...))])) 3129 3130(error/warning-mat argcnt 3131 "; cp1in argument-count error\n\n(define f (lambda () (import scheme) (car)))\n(f)\n" 3132 "; cp1in argument-count error\n\n(define f (lambda () (import scheme) (car '(a b) '(c d))))\n(f)\n" 3133 "; cp1in argument-count error\n\n(define f (lambda () (let ([g (lambda () 0)]) (g 7))))\n(f)\n" 3134 "; cp1in argument-count error\n\n(define f (lambda () (let ([g (lambda (x) 0)]) (g))))\n(f)\n" 3135) 3136 3137(error-mat syntax 3138 "; eval-when syntax error\n\n(eval-when (compile load eval))" 3139 "; eval-when syntax error\n\n(eval-when (never) 3)" 3140 "; begin syntax error\n\n(begin 3 . 4)" 3141 "; application syntax error\n\n(f 1 2 . 3)" 3142 "; define syntax error\n\n(define foo 3 4)" 3143 "; define-syntax syntax error\n\n(define-syntax (foo x y) z)" 3144 "; cond syntax error\n\n(cond . 17)" 3145 "; lambda syntax error\n\n(lambda (x 3 y) 3)" 3146) 3147 3148(mat sci-bug 3149 (fl~= (expt 10.0 (- 21)) 1e-21) 3150 (fl~= (flexpt 10.0 (- 21.0)) 1e-21) 3151) 3152 3153(mat apropos 3154 (error? (apropos 3)) 3155 (error? (apropos '(hit me))) 3156 (error? (apropos 'a 'b)) 3157 (error? (apropos 'a 'b 'c)) 3158 (error? (apropos)) 3159 (let ([ls (apropos-list 'str)]) 3160 (and (memq 'string=? ls) 3161 (memq 'display-string ls) 3162 (memq 'record-constructor ls) 3163 (not (memq 'cons ls)) 3164 (not (memq 'straightjacket ls)))) 3165 (let ([ls (apropos-list "str")]) 3166 (and (memq 'string=? ls) 3167 (memq 'display-string ls) 3168 (memq 'record-constructor ls) 3169 (not (memq 'cons ls)) 3170 (not (memq 'straightjacket ls)))) 3171 (equal? 3172 (with-output-to-string (lambda () (apropos 'substring))) 3173 "interaction environment:\n substring, substring-fill!\n(chezscheme):\n substring, substring-fill!\n(rnrs):\n substring\n(rnrs base):\n substring\n(scheme):\n substring, substring-fill!\n") 3174 (equal? 3175 (with-output-to-string (lambda () (apropos "substring"))) 3176 "interaction environment:\n substring, substring-fill!\n(chezscheme):\n substring, substring-fill!\n(rnrs):\n substring\n(rnrs base):\n substring\n(scheme):\n substring, substring-fill!\n") 3177 (equal? 3178 (with-output-to-string (lambda () (apropos 'substring (copy-environment (scheme-environment) #t '(substring-fill!))))) 3179 "supplied environment:\n substring-fill!\n(chezscheme):\n substring, substring-fill!\n(rnrs):\n substring\n(rnrs base):\n substring\n(scheme):\n substring, substring-fill!\n") 3180 (null? (apropos-list 'thisshouldntbefound)) 3181 (equal? 3182 (apropos-list 'apropos) 3183 '(apropos apropos-list 3184 ((chezscheme) apropos apropos-list) 3185 ((scheme) apropos apropos-list))) 3186 (equal? (apropos-list '$apropos-unbound1) '()) 3187 (error? (eval '$apropos-unbound1)) 3188 (equal? (apropos-list '$apropos-unbound1) '()) 3189 (equal? (apropos-list '$apropos-bound1) '()) 3190 (eq? (eval '(set! $apropos-bound1 17)) (void)) 3191 (equal? (apropos-list '$apropos-bound1) '($apropos-bound1)) 3192 (begin (define $apropos-env (copy-environment (scheme-environment))) 3193 (environment? $apropos-env)) 3194 (equal? (apropos-list '$apropos-unbound2 $apropos-env) '()) 3195 (error? (eval '$apropos-unbound2 $apropos-env)) 3196 (equal? (apropos-list '$apropos-unbound2 $apropos-env) '()) 3197 (equal? (apropos-list '$apropos-bound2 $apropos-env) '()) 3198 (eq? (eval '(set! $apropos-bound2 17) $apropos-env) (void)) 3199 (equal? (apropos-list '$apropos-bound2 $apropos-env) '($apropos-bound2)) 3200) 3201 3202(mat p423 ; tests for p423 compiler 3203 (equal? 3204 (list 3205 '() 3206 75 3207 (- 2 4) 3208 (* -6 7) 3209 (cons 0 '()) 3210 (cons (cons 0 '()) (cons 1 '())) 3211 (cdr (cons 16 32)) 3212 (void) 3213 (if #f 3) 3214 (let () 3) 3215 (let ((x 0)) x) 3216 (let ([x 0]) x x) 3217 (let ([x 17]) (+ x x)) 3218 (let ([q (add1 (add1 2))]) q) 3219 (+ 20 (if #t 122)) 3220 (let ((x 16) 3221 (y 128)) 3222 (* x y)) 3223 (if #t 3224 (+ 20 3225 (if #t 122)) 3226 10000) 3227 (let ([x 3]) 3228 (let ([y (+ x (quote 4))]) 3229 (+ x y))) 3230 (let ((x '(#(1 2 (3 #(4))) #() 3 #t))) x) 3231 (not (if #f #t (not #f))) 3232 (let ([x 0] [y 4000]) x) 3233 (let ((x (cons 16 32))) (pair? x)) 3234 (begin (if #f 7) 3) 3235 (begin (< 1 2) 3) 3236 (begin '(1 . 2) 3) 3237 (begin (if (zero? 4) 7) 3) 3238 (let ([x 0]) (begin (if (zero? x) 7) x)) 3239 (let ([x 0]) (begin (if (zero? x) (begin x 7)) x)) 3240 (let ([x 0] [z 9000]) 3241 (begin (if (zero? x) (begin x 7)) z)) 3242 (let ([x 0] [z 9000]) 3243 (begin (if (zero? x) (begin (set! x x) 7)) 3244 (+ x z))) 3245 (let ([x 4]) (begin (+ (begin (set! x 17) 3) 4) x)) 3246 (let ([x (cons 0 '())]) 3247 (begin (if x (set-car! x (car x))) x)) 3248 (let ([x (cons 0 '())]) 3249 (begin (if x (set-car! x (+ (car x) (car x)))) x)) 3250 (let ([x (cons 0 '())]) 3251 (if (zero? (car x)) (begin (set-car! x x) 7) x)) 3252 (let ([x (cons 0 '())]) 3253 (let ([q x]) (if (zero? (car x)) (begin (set-car! q x) 7) x))) 3254 (let ([x 0]) (if (zero? x) (begin (set! x (+ x 5000)) x) 20)) 3255 (let ([y 0]) (begin (if #t (set! y y)) y)) 3256 (begin (if #t #t #t) #f) 3257 (begin (if (if #t #t #f) (if #t #t #f) (if #t #t #f)) #f) 3258 (let 3259 ([x 0] 3260 [y 4000] 3261 [z 9000]) 3262 (let ((q (+ x z))) 3263 (begin 3264 (if (zero? x) (begin (set! q (+ x x)) 7)) 3265 (+ y y) 3266 (+ x z)))) 3267 (let ([x (let ([y 2]) y)] 3268 [y 5]) 3269 (add1 x)) 3270 (let ([y 4000]) (+ y y)) 3271 ((lambda (y) y) 4000) 3272 (let ([f (lambda (x) x)]) 3273 (add1 (f 0))) 3274 (let ([f (lambda (y) y)]) (f (f 4))) 3275 ((lambda (f) (f (f 4))) (lambda (y) y)) 3276 ((let ([a 4000]) 3277 (lambda (b) (+ a b))) 3278 5000) 3279 (((lambda (a) 3280 (lambda (b) 3281 (+ a b))) 3282 4000) 3283 5000) 3284 (let ([f (lambda (x) (add1 x))]) (f (f 0))) 3285 ((lambda (f) (f (f 0))) (lambda (x) (add1 x))) 3286 (let ([x 0] [f (lambda (x) x)]) 3287 (let ([a (f x)] [b (f x)] [c (f x)]) (+ (+ a b) c))) 3288 (let ([x 0] [y 1] [z 2] [f (lambda (x) x)]) 3289 (let ([a (f x)] [b (f y)] [c (f z)]) 3290 (+ (+ a b) c))) 3291 (let ([f (lambda (x y) x)]) 3292 (f 0 1)) 3293 (let ([f (lambda (x y) x)]) 3294 (let ([a (f 0 1)]) (f a a))) 3295 (let ([x 0] [y 1] [z 2] [f (lambda (x y z) x)]) 3296 (let ([a (f x y z)]) (f a a a))) 3297 (let ([x 0] [y 1] [z 2] [f (lambda (x y z) x)]) 3298 (let ([a (f x y z)] [b y] [c z]) (f a b c))) 3299 (let ([f (lambda (a b c d) 3300 (+ a d))]) 3301 (f 0 1 2 3)) 3302 (let ([f (lambda (x) x)]) 3303 (+ (f 0) 3304 (let ([a 0] [b 1] [c 2]) 3305 (+ (f a) (+ (f b) (f c)))))) 3306 (let ([f (lambda (x) x)]) 3307 (+ (f 0) 3308 (let ([a 0] [b 1] [c 2]) 3309 (add1 (f a))))) 3310 (let ([f (lambda (x) x)]) 3311 (let ([a 1]) 3312 (* (+ (f a) a) a))) 3313 3314 (let ([k (lambda (x y) x)]) 3315 (let ([b 17]) 3316 ((k (k k 37) 37) b (* b b)))) 3317 3318 (let ([f (lambda () 3319 (let ([n 256]) 3320 (let ([v (make-vector n)]) 3321 (vector-set! v 32 n) 3322 (vector-ref v 32))))]) 3323 (pair? (f))) 3324 (let ((w 4) (x 8) (y 16) (z 32)) 3325 (let ((f (lambda () 3326 (+ w (+ x (+ y z)))))) 3327 (f))) 3328 (let ([f (lambda (x) x)]) 3329 (+ (f 0) (let ([a 0] [b 1] [c 2] [d 3]) 3330 (+ (f a) 3331 (+ (f b) 3332 (+ (f c) 3333 (f d))))))) 3334 ; test use of keywords/primitives as variables 3335 (let ([quote (lambda (x) x)] 3336 [let (lambda (x y) (- y x))] 3337 [if (lambda (x y z) (cons x z))] 3338 [cons (lambda (x y) (cons y x))] 3339 [+ 16]) 3340 (set! + (* 16 2)) 3341 (cons (let ((quote (lambda () 0))) +) 3342 (if (quote (not #f)) 3343 720000 3344 -1))) 3345 (letrec () 3) 3346 (let ([a 0]) (letrec ([a (lambda () 0)] [b (lambda () 11)]) (set! a 11))) 3347 (let ([a 0]) (letrec ([a (lambda () (set! a 0))] [b 11]) (a))) 3348 (let ([a 0]) (let ([a (set! a 0)] [b 11]) a)) 3349 (let ([a 5]) (let ([a 0] [b (set! a (+ a 11))]) a)) 3350 (let ([x (lambda () 4)]) 3351 (letrec ([y (lambda () (z))] [z x]) (y))) 3352 (letrec ([a (lambda () 0)]) (a)) 3353 (letrec ([a (lambda () 0)] [b (lambda () 11)]) (a)) 3354 (let ([z 4]) 3355 (letrec ([f (lambda (x) 3356 (letrec ([g (lambda (y) 3357 (if (= y 0) 0 3358 (f (- y 1))))]) 3359 (g x)))]) 3360 (f z))) 3361 (let ([x 0]) (letrec ([a (lambda () 0)] [b (lambda () 11)]) (set! x 11))) 3362 (let ([a 0]) (let ([b (set! a 0)]) a)) 3363 (let ([a 0]) (let ([a (set! a 0)]) (let ([b 11]) a))) 3364 (let ([a 0]) (let ([a 0]) (let ([b (set! a 11)]) a))) 3365 (let ([a 0]) (let ([a 0]) (let ([b 11]) (set! a 11)))) 3366 (let ([f (let ([x 1]) (lambda (y) (+ x y)))]) 3367 (let ([x 0]) (f (f x)))) 3368 ((let ([t (lambda (x) (+ x 50))]) 3369 (lambda (f) (t (f 1000)))) 3370 (lambda (y) (+ y 2000))) 3371 (let ([x 0]) 3372 (let ([f (let ([x 1] 3373 [z x]) 3374 (lambda (y) 3375 (+ x (+ z y))))]) 3376 (f (f x)))) 3377 (((lambda (t) 3378 (lambda (f) (t (f 1000)))) 3379 (lambda (x) (+ x 50))) 3380 (lambda (y) (+ y 2000))) 3381 ((let ([t 50]) 3382 (lambda (f) 3383 (+ t (f)))) 3384 (lambda () 2000)) 3385 (((lambda (t) 3386 (lambda (f) 3387 (+ t (f)))) 3388 50) 3389 (lambda () 2000)) 3390 ((let ([x 300]) 3391 (lambda (y) (+ x y))) 3392 400) 3393 (let ([x 3] [f (lambda (x y) x)]) 3394 (f (f 0 0) x)) 3395 (let ([x 3] [f (lambda (x y) x)]) 3396 (if (f 0 0) (f (f 0 0) x) 0)) 3397 (let ([x02 3] [f01 (lambda (x04 y03) x04)]) 3398 (if (not x02) (f01 (f01 0 0) x02) 0)) 3399 (let ((f (lambda (x) (if (if (pair? x) (not (eq? (car x) 0)) #f) x #f)))) 3400 (f (cons 0 0))) 3401 (let ((f (lambda (x) 3402 (if (if x (not (if (pair? x) (not (eq? (car x) 0)) #f)) #f) 3403 x #f)))) 3404 (f 0)) 3405 (let ((f (lambda (x) (if (if (pair? x) #t (null? x)) x '())))) 3406 (f 0)) 3407 (let ([y 4]) 3408 (let ([f (lambda (y) y)]) 3409 (f (f y)))) 3410 (let ([y 4]) 3411 (let ([f (lambda (x y) 0)]) 3412 (f (f y y) (f y y)))) 3413 (let ([y 4]) 3414 (let ([f (lambda (x y) 0)]) 3415 (f (f y y) (f y (f y y))))) 3416 (let ([y 4]) 3417 (let ([f (lambda (x y) 0)]) 3418 (f (f y (f y y)) (f y (f y y))))) 3419 ((lambda (y) ((lambda (f) (f (f y))) (lambda (y) y))) 4) 3420 (let ([f (lambda (x) (+ x x))]) (f 4000)) 3421 (let ((x (if 1000 2000 3000))) 3422 x) 3423 (let ([f (lambda (x) x)]) 3424 (add1 (if #f 1 (f 22)))) 3425 (let ([f (lambda (x) x)]) 3426 (if (f (zero? 23)) 1 22)) 3427 (let ([f (lambda (x) (if x (not x) x))] 3428 [f2 (lambda (x) (* 10 x))] 3429 [x 23]) 3430 (add1 (if (f (zero? x)) 1 (* x (f2 (sub1 x)))))) 3431 (let ([f (lambda () 0)]) 3432 (let ([x (f)]) 3433 1)) 3434 (let ([f (lambda () 0)]) 3435 (begin (f) 1)) 3436 (let ([f (lambda (x) x)]) 3437 (if #t (begin (f 3) 4) 5)) 3438 (let ([f (lambda (x) x)]) 3439 (begin (if #t (f 4) 5) 6)) 3440 (let ([f (lambda (x) x)]) 3441 (begin 3442 (if (f #t) 3443 (begin 3444 (f 3) 3445 (f 4)) 3446 (f 5)) 3447 (f 6))) 3448 (let ([f (lambda (x) (add1 x))]) 3449 (f (let ([f 3]) (+ f 1)))) 3450 (let ((x 15) 3451 (f (lambda (h v) (* h v))) 3452 (k (lambda (x) (+ x 5))) 3453 (g (lambda (x) (add1 x)))) 3454 (k (g (let ((g 3)) (f g x))))) 3455 (let ([x 4]) 3456 (let ([f (lambda () x)]) 3457 (set! x 5) 3458 (f))) 3459 (let ([x (let ([y 2]) 3460 y)]) 3461 x) 3462 (let ([x (if #t (let ([y 2]) 3463 y) 3464 1)]) 3465 x) 3466 (let ([x (let ([y (let ([z 3]) 3467 z)]) 3468 y)]) 3469 x) 3470 (let ([x (if #t (let ([y (if #t (let ([z 3]) 3471 z) 3472 2)]) 3473 y) 3474 1)]) 3475 x) 3476 (+ (let ([x 3]) 3477 (add1 x)) 3478 4) 3479 (+ (let ([x 3] [y 4]) 3480 (* x y)) 3481 4) 3482 (let ([x (add1 (let ([y 4]) y))]) x) 3483 (let ([x (add1 (letrec ([y (lambda () 4)]) (y)))]) x) 3484 (let ([x (+ (let ([y 4]) y) (let ([y 4]) y))]) (add1 x)) 3485 (let ([z 0]) 3486 (let ([x z]) 3487 z 3488 x)) 3489 (let ([z 0]) 3490 (let ([x (begin (let ([y 2]) (set! z y)) z)]) 3491 x)) 3492 (let ([x (begin (let ([y 2]) (set! y y)) (let ([z 3]) z))]) 3493 x) 3494 (letrec ([one (lambda (n) (if (zero? n) 1 (one (sub1 n))))]) 3495 (one 13)) 3496 (letrec 3497 ((even (lambda (x) (if (zero? x) #t (odd (sub1 x))))) 3498 (odd (lambda (x) (if (zero? x) #f (even (sub1 x)))))) 3499 (odd 13)) 3500 (let ([t #t] 3501 [f #f]) 3502 (letrec 3503 ((even (lambda (x) (if (zero? x) t (odd (sub1 x))))) 3504 (odd (lambda (x) (if (zero? x) f (even (sub1 x)))))) 3505 (odd 13))) 3506 (let ((even (lambda (x) x))) 3507 (even 3508 (letrec 3509 ((even (lambda (x) (if (zero? x) #t (odd (sub1 x))))) 3510 (odd (lambda (x) (if (zero? x) #f (even (sub1 x)))))) 3511 (odd 13)))) 3512 (letrec ((fact (lambda (n) (if (zero? n) 1 (* n (fact (sub1 n))))))) 3513 (fact 5)) 3514 (letrec ([remq (lambda (x ls) 3515 (if (null? ls) 3516 '() 3517 (if (eq? (car ls) x) 3518 (remq x (cdr ls)) 3519 (cons (car ls) (remq x (cdr ls))))))]) 3520 (remq 3 '(3 1 3))) 3521 (let ([x 5]) 3522 (letrec 3523 ([a 3524 (lambda (u v w) (if (zero? u) (b v w) (a (- u 1) v w)))] 3525 [b 3526 (lambda (q r) 3527 (let ([p (* q r)]) 3528 (letrec 3529 ([e (lambda (n) (if (zero? n) (c p) (o (- n 1))))] 3530 [o (lambda (n) (if (zero? n) (c x) (e (- n 1))))]) 3531 (e (* q r)))))] 3532 [c (lambda (x) (* 5 x))]) 3533 (a 3 2 1))) 3534 (let ([f (lambda () 80)]) 3535 (let ([a (f)] [b (f)]) 3536 0)) 3537 (let ([f (lambda () 80)]) 3538 (let ([a (f)] [b (f)]) 3539 (* a b))) 3540 (let ([f (lambda () 80)] 3541 [g (lambda () 80)]) 3542 (let ([a (f)] [b (g)]) 3543 (* a b))) 3544 (let ((f (lambda (x) (add1 x))) 3545 (g (lambda (x) (sub1 x))) 3546 (t (lambda (x) (add1 x))) 3547 (j (lambda (x) (add1 x))) 3548 (i (lambda (x) (add1 x))) 3549 (h (lambda (x) (add1 x))) 3550 (x 80)) 3551 (let ((a (f x)) (b (g x)) (c (h (i (j (t x)))))) 3552 (* a (* b (+ c 0))))) 3553 (let ((x 3000)) 3554 (if (integer? x) 3555 (let ((y (cons x '()))) 3556 (if (if (pair? y) (null? (cdr y)) #f) 3557 (+ x 5000) 3558 (- x 3000))))) 3559 (let ((x (cons 1000 2000))) 3560 (if (pair? x) 3561 (let ((temp (car x))) 3562 (set-car! x (cdr x)) 3563 (set-cdr! x temp) 3564 (+ (car x) (cdr x))) 3565 10000000)) 3566 (let ((v (make-vector 3))) 3567 (vector-set! v 0 10) 3568 (vector-set! v 1 20) 3569 (vector-set! v 2 30) 3570 (if (vector? v) 3571 (+ (+ (vector-length v) (vector-ref v 0)) 3572 (+ (vector-ref v 1) (vector-ref v 2))) 3573 10000)) 3574 (let ([fact 3575 (lambda (fact n) 3576 (if (zero? n) 1 (* (fact fact (sub1 n)) n)))]) 3577 (fact fact 5)) 3578 (let ([f (lambda (x) (+ x 1000))]) 3579 (if (zero? (f -2)) (f 6000) (f (f 8000)))) 3580 (let ([f (lambda (x) (+ x 1000))]) 3581 (if (zero? (f -1)) (f 6000) (f (f 8000)))) 3582 (let ((f (lambda (x y) (+ x 1000)))) 3583 (+ (if (f 3000 (begin 0 0 0)) (f (f 4000 0) 0) 8000) 2000)) 3584 ((((lambda (x) 3585 (lambda (y) 3586 (lambda (z) 3587 (+ x (+ y (+ z y)))))) 3588 5) 6) 7) 3589 ((((((lambda (x) 3590 (lambda (y) 3591 (lambda (z) 3592 (lambda (w) 3593 (lambda (u) 3594 (+ x (+ y (+ z (+ w u))))))))) 3595 5) 6) 7) 8) 9) 3596 (let ((f (lambda (x) x))) 3597 (if (procedure? f) 3598 #t 3599 #f)) 3600 (let ((sum (lambda (sum ls) 3601 (if (null? ls) 3602 0 3603 (+ (car ls) (sum sum (cdr ls))))))) 3604 (sum sum (cons 1 (cons 2 (cons 3 '()))))) 3605 (let ((v (make-vector 5)) 3606 (w (make-vector 7))) 3607 (vector-set! v 0 #t) 3608 (vector-set! w 3 #t) 3609 (if (boolean? (vector-ref v 0)) 3610 (vector-ref w 3) 3611 #f)) 3612 (let ((a 5) (b 4)) 3613 (if (< b 3) 3614 (eq? a (+ b 1)) 3615 (if (<= b 3) 3616 (eq? (- a 1) b) 3617 (= a (+ b 2))))) 3618 (let ((a 5) (b 4)) 3619 (if #f 3620 (eq? a (+ b 1)) 3621 (if #f 3622 (eq? (- a 1) b) 3623 (= a (+ b 2))))) 3624 (((lambda (a) 3625 (lambda () 3626 (+ a (if #t 200)) 3627 1500)) 3628 1000)) 3629 (((lambda (b) 3630 (lambda (a) (set! a (if 1 2)) (+ a b))) 3631 100) 3632 200) 3633 ((((lambda (a) 3634 (lambda (b) 3635 (set! a (if b 200)) 3636 (lambda (c) 3637 (set! c (if 300 400)) 3638 (+ a (+ b c))))) 3639 1000) 3640 2000) 3641 3000) 3642 ((((lambda (a) (lambda (b) (lambda (c) (+ a (+ b c))))) 10) 20) 30) 3643 (+ 2 3) 3644 ((lambda (a) (+ 2 a)) 3) 3645 (((lambda (b) (lambda (a) (+ b a))) 3) 2) 3646 ((lambda (b) ((lambda (a) (+ b a)) 2)) 3) 3647 ((lambda (f) (f (f 5))) (lambda (x) x)) 3648 ((let ((f (lambda (x) (+ x 3000)))) 3649 (lambda (y) (f (f y)))) 3650 2000) 3651 (let ((n 17) (s 18) (t 19)) 3652 (let ((st (make-vector 5))) 3653 (vector-set! st 0 n) 3654 (vector-set! st 1 s) 3655 (vector-set! st 2 t) 3656 (if (not (vector? st)) 3657 10000 3658 (vector-length st)))) 3659 (let ((s (make-vector 1))) 3660 (vector-set! s 0 82) 3661 (if (eq? (vector-ref s 0) 82) 1000 2000)) 3662 (not 17) 3663 (not #f) 3664 (let ([fact 3665 (lambda (fact n acc) 3666 (if (zero? n) acc (fact fact (sub1 n) (* n acc))))]) 3667 (fact fact 5 1)) 3668 ((lambda (b c a) 3669 (let ((b (+ b a)) 3670 (a (+ a (let ((a (+ b b)) 3671 (c (+ c c))) 3672 (+ a a))))) 3673 (* a a))) 3674 2 3 4) 3675 (let ((f (lambda (x) (lambda () (x))))) ((f (lambda () 3)))) 3676 (letrec ((f (lambda (x) (if (zero? x) 1 (* x (f (- x 1))))))) 3677 (let ([q 17]) 3678 (let ((g (lambda (a) (set! q 10) (lambda () (a q))))) 3679 ((g f))))) 3680 (letrec ((f (lambda (x) (if (zero? x) 1 (* x (f (- x 1))))))) 3681 (let ((g (lambda (a) (lambda (b) (a b))))) 3682 ((g f) 10))) 3683 (letrec ((f (lambda () (+ a b))) 3684 (g (lambda (y) (set! g (lambda (y) y)) (+ y y))) 3685 (a 17) 3686 (b 35) 3687 (h (cons (lambda () a) (lambda (v) (set! a v))))) 3688 (let ((x1 (f)) (x2 (g 22)) (x3 ((car h)))) 3689 (let ((x4 (g 22))) 3690 ((cdr h) 3) 3691 (let ((x5 (f)) (x6 ((car h)))) 3692 (cons x1 (cons x2 (cons x3 (cons x4 (cons x5 x6))))))))) 3693 (letrec ((f (lambda () (+ a b))) 3694 (a 17) 3695 (b 35) 3696 (h (cons (lambda () a) (lambda () b)))) 3697 (cons (f) (cons a (cons b (cons ((car h)) ((cdr h))))))) 3698 (letrec ((f (lambda (x) 3699 (letrec ((x 3)) 3)))) 3700 (letrec ((g (lambda (x) (letrec ((y 14)) (set! y 7) y)))) 3701 (set! g (cons g 3)) 3702 (letrec ((h (lambda (x) x)) (z 42)) 3703 (cons (cdr g) (h z))))) 3704 (let ([t #t] [f #f]) 3705 (let ([bools (cons t f)] [id (lambda (x) (if (not x) f t))]) 3706 (letrec 3707 ([even (lambda (x) (if (zero? x) (id (car bools)) (odd (- x 1))))] 3708 [odd (lambda (y) (if (zero? y) (id (cdr bools)) (even (- y 1))))]) 3709 (odd 5)))) 3710 (letrec ([fib (lambda (x) 3711 (let ([decrx (lambda () (set! x (- x 1)))]) 3712 (if (< x 2) 3713 1 3714 (+ (begin (decrx) (fib x)) 3715 (begin (decrx) (fib x))))))]) 3716 (fib 10)) 3717 (letrec ([fib (lambda (x) 3718 (let ([decrx (lambda () (lambda (i) (set! x (- x i))))]) 3719 (if (< x 2) 3720 1 3721 (+ (begin ((decrx) 1) (fib x)) 3722 (begin ((decrx) 1) (fib x))))))]) 3723 (fib 10)) 3724 (let ((f (lambda (g u) (g (if u (g 37) u))))) 3725 (f (lambda (x) x) 75)) 3726 3727 (let ((f (lambda (h u) (h (if u (h (+ u 37)) u)))) 3728 (w 62)) 3729 (f (lambda (x) (- w x)) (* 75 w))) 3730 3731 (let ([t #t] [f #f]) 3732 (let ([bools (cons t f)] [id (lambda (x) (if (not x) f t))]) 3733 (letrec 3734 ([even (lambda (x) (if (id (zero? x)) (car bools) (odd (- x 1))))] 3735 [odd (lambda (y) (if (zero? y) (id (cdr bools)) (even (- y 1))))]) 3736 (odd 5)))) 3737 3738 ((lambda (x y z) 3739 (let ((f (lambda (u v) (begin (set! x u) (+ x v)))) 3740 (g (lambda (r s) (begin (set! y (+ z s)) y)))) 3741 (* (f '1 '2) (g '3 '4)))) 3742 '10 '11 '12) 3743 3744 ((lambda (x y z) 3745 (let ((f '#f) 3746 (g (lambda (r s) (begin (set! y (+ z s)) y)))) 3747 (begin 3748 (set! f 3749 (lambda (u v) (begin (set! v u) (+ x v)))) 3750 (* (f '1 '2) (g '3 '4))))) 3751 '10 '11 '12) 3752 3753 (letrec ((f (lambda (x) (+ x 1))) 3754 (g (lambda (y) (f (f y))))) 3755 (+ (f 1) (g 1))) 3756 3757 (let ((y 3)) 3758 (letrec 3759 ((f (lambda (x) (if (zero? x) (g (+ x 1)) (f (- x y))))) 3760 (g (lambda (x) (h (* x x)))) 3761 (h (lambda (x) x))) 3762 (g 39))) 3763 3764 (letrec ((f (lambda (x) (+ x 1))) 3765 (g (lambda (y) (f (f y))))) 3766 (set! f (lambda (x) (- x 1))) 3767 (+ (f 1) (g 1))) 3768 3769 (letrec ([f (lambda () (+ a b))] 3770 [a 17] 3771 [b 35] 3772 [h (cons (lambda () a) (lambda () b))]) 3773 (cons (f) (cons a (cons b (cons ((car h)) ((cdr h))))))) 3774 3775 (let ((v (make-vector 8))) 3776 (vector-set! v 0 '()) 3777 (vector-set! v 1 (void)) 3778 (vector-set! v 2 #f) 3779 (vector-set! v 3 (cons 3 4)) 3780 (vector-set! v 4 (make-vector 3)) 3781 (vector-set! v 5 #t) 3782 (vector-set! v 6 2) 3783 (vector-set! v 7 5) 3784 (vector-ref v (vector-ref v 6))) 3785 3786 (let ([x 5] [th (let ((a 1)) (lambda () a))]) 3787 (letrec ([fact (lambda (n th) 3788 (if (zero? n) 3789 (th) 3790 (* n (fact (- n 1) th))))]) 3791 (fact x th))) 3792 3793 (let ([negative? (lambda (n) (< n 0))]) 3794 (letrec 3795 ([fact 3796 (lambda (n) 3797 (if (zero? n) 3798 1 3799 (* n (fact (- n 1)))))] 3800 [call-fact 3801 (lambda (n) 3802 (if (not (negative? n)) 3803 (fact n) 3804 (- 0 (fact (- 0 n)))))]) 3805 (cons (call-fact 5) (call-fact -5)))) 3806 3807 (letrec ([iota-fill! 3808 (lambda (v i n) 3809 (if (not (= i n)) 3810 (begin 3811 (vector-set! v i i) 3812 (iota-fill! v (+ i 1) n))))]) 3813 (let ([n 4]) 3814 (let ([v (make-vector n)]) 3815 (iota-fill! v 0 n) 3816 v))) 3817 3818 ; try with operand-constraints reg/int? returning false for ints 3819 ; to make sure that nested operands are being pulled out properly 3820 (let ((f (lambda (x) x))) 3821 (let ((g (lambda (x) (let ((y (+ x x))) (f x) (cons x y))))) 3822 (g 3))) 3823 3824 ; nested test examples 3825 (+ (let ((x 7) (y 2)) (if (if (= x 7) (< y 0) (<= 0 y)) 77 88)) 99) 3826 (+ (let ((x 7) (y -22)) (if (if (= x 7) (< y 0) (<= 0 y)) 77 88)) 99) 3827 (+ (let ((x 8) (y 2)) (if (if (= x 7) (< y 0) (<= 0 y)) 77 88)) 99) 3828 (+ (let ((x 8) (y -22)) (if (if (= x 7) (< y 0) (<= 0 y)) 77 88)) 99) 3829 3830 ; make-vector with non-constant operand and improper alignment 3831 (let ([x 6]) 3832 (let ([v (make-vector x)]) 3833 (vector-set! v 0 3) 3834 (vector-set! v 1 (cons (vector-ref v 0) 2)) 3835 (vector-set! v 2 (cons (vector-ref v 1) 2)) 3836 (vector-set! v 3 (cons (vector-ref v 2) 2)) 3837 (vector-set! v 4 (cons (vector-ref v 3) 2)) 3838 (vector-set! v 5 (cons (vector-ref v 4) 2)) 3839 (cons (pair? (vector-ref v 5)) (car (vector-ref v 4))))) 3840 3841 ; nest some lambdas 3842 (((((lambda (a) 3843 (lambda (b) 3844 (lambda (c) 3845 (lambda (d) 3846 (cons (cons a b) (cons c d)))))) 3847 33) 55) 77) 99) 3848 3849 ; test set! on letrec rhs 3850 (letrec ([b 4]) 3851 (letrec ([a (lambda (x) (set! a x) 5)]) 3852 (a (lambda (x) x)) 3853 (set! b 8) 3854 (a 7))) 3855 3856 ; test optimize-letrec---contributed by Jeremiah Penery 3857 (letrec ([q (cons (lambda (x) 3858 (letrec ([b r]) 3859 b)) 3860 '())] 3861 [r 10]) 3862 ((car q) 5)) 3863 3864 ; normalize-context test a bit---contributed by Andy Keep 3865 (let ((x 5)) (if (set! x 6) 1 0) x) 3866 3867 ; stress the register allocator 3868 (let ((a 17)) 3869 (let ((f (lambda (x) 3870 (let ((x1 (+ x 1)) (x2 (+ x 2))) 3871 (let ((y1 (* x1 7)) (y2 (* x2 7))) 3872 (let ((z1 (- y1 x1)) (z2 (- y2 x2))) 3873 (let ((w1 (* z1 a)) (w2 (* z2 a))) 3874 (let ([g (lambda (b) 3875 (if (= b a) 3876 (cons x1 (cons y1 (cons z1 '()))) 3877 (cons x2 (cons y2 (cons z2 '())))))] 3878 [h (lambda (c) 3879 (if (= c x) w1 w2))]) 3880 (if (if (= (* x x) (+ x x)) 3881 #t 3882 (< x 0)) 3883 (cons (g 17) (g 16)) 3884 (cons (h x) (h (- x 0)))))))))))) 3885 (cons (f 2) (cons (f -1) (cons (f 3) '()))))) 3886 3887 (let ([x (cons #f #t)] [y 17]) 3888 (if (if (car x) #t (< y 20)) 3889 (* y (* y 2)) 3890 (void))) 3891 (let ((v (make-vector (add1 37)))) 3892 (vector-set! v 0 (boolean? v)) 3893 (vector-set! v (* 3 11) (vector-length v)) 3894 ((let ((w (cons 33 '()))) 3895 (lambda () 3896 (if (not (eq? w (cons 33 '()))) 3897 (begin 3898 (set-cdr! w (vector? v)) 3899 w)))))) 3900 (let ((v (make-vector (add1 37)))) 3901 (vector-set! v 0 (boolean? v)) 3902 (vector-set! v (* 3 11) #t) 3903 ((let ((w (cons (sub1 34) #f))) 3904 (lambda () 3905 (set-cdr! w v) 3906 (if (not (eq? w (cons (- (vector-length v) 5) v))) 3907 (begin 3908 (set-car! w (vector-ref (cdr w) (car w))) 3909 w)))))) 3910 3911 ; make sure uncover-live passes don't leave behind unassigned 3912 ; or unlisted variables as a result of dead code. 3913 (letrec ([a (lambda () 1)]) 3914 (let ([b 2]) 3915 (if #t 3916 3 3917 (begin (a) b)))) 3918 3919 ; stress test introduce-unspillables by generating 3920 ; (mset fp i (+ (mref fp j) (mref fp k))) 3921 (let ((f (lambda (x) x))) 3922 (let ((x 1) (y 2)) 3923 (let ((z (f x))) 3924 (let ((w (+ x y))) 3925 (let ((q (f w))) 3926 w))))) 3927 3928 ; stress test introduce-unspillables by generating 3929 ; (mset (mref fp i) tmp (mref fp k))---can't actually get 3930 ; (mset (mref fp i) (mref fp j) (mref fp k)), 'cause we 3931 ; have to add in the vector-data offset 3932 (let ((f (lambda (x) x))) 3933 (let ((x (make-vector 4)) (y 2) (z 17)) 3934 (vector-set! x y z) 3935 (let ((w (f x))) 3936 (cons (+ y z) x)))) 3937 (letrec ([s0 (lambda (a b c d e) 3938 (if (null? a) 3939 (cons b (cons c (cons d e))) 3940 (if (eq? (car a) #t) 3941 (s1 (cdr a) (+ b 1) c d e) 3942 (s2 (cdr a) b (+ c 1) d e))))] 3943 [s1 (lambda (a b c d e) 3944 (if (eq? (car a) #t) 3945 (s0 (cdr a) b c (+ d 1) e) 3946 (s1 (cdr a) b c d (+ e 1))))] 3947 [s2 (lambda (a b c d e) 3948 (if (eq? (car a) #t) 3949 (s0 (cdr a) (+ b 1) d c e) 3950 (s2 (cdr a) e d b c)))]) 3951 (s0 '(#t #f #t #f #t #f #f #f #f #t) 10 20 30 40)) 3952 3953 ; stress optimize-letrec. in the outer letrec, q should be treated as 3954 ; 'lambda'. in the inner letrec, f should be treated as simple, 3955 ; d as 'lambda', and a, b, c, and e as complex. 3956 ; should evaluate to ((40 #f 105 15 . #t) #t 252 36 #t 9841 . 18) 3957 (letrec ((q (lambda (x) (if (< x 1) 13 (+ (* (q (- x 2)) 3) 1))))) 3958 (letrec ((a (lambda (x) x)) 3959 (b (cons (lambda () (* c 7)) (lambda (v) (set! c v)))) 3960 (c 15) 3961 (d (lambda (x) (set! a x) (a x))) 3962 (e (q 12)) 3963 (f 18)) 3964 (let ([a0 (a #f)] [b0 ((car b))] [c0 c]) 3965 (let ([d0 (d (lambda (z) #t))]) 3966 ((cdr b) (* f 2)) 3967 (cons (cons (q 1) (cons a0 (cons b0 (cons c0 d0)))) 3968 (cons (a #f) 3969 (cons ((car b)) 3970 (cons c (cons (procedure? d) (cons e f)))))))))) 3971 3972 ;; Jie Li 3973 (let ((a 5)) 3974 (let ((b (cons a 6))) 3975 (let ((f (lambda(x) (* x a)))) 3976 (begin (if (- (f a) (car b)) 3977 (begin (set-car! b 3978 (if (not a) (* 2 a) (+ 2 a))) 3979 (f a)) 3980 (if (not (not (< (f a) b))) 3981 (f a))) 3982 (not 3) 3983 (void) 3984 (f (car b)))))) 3985 (letrec ([f (lambda (x y) (if (not x) (g (add1 x) (add1 y)) (h (+ x y))))] 3986 [g (lambda (u v) 3987 (let ([a (+ u v)] 3988 [b (* u v)]) 3989 (letrec ([e (lambda (d) 3990 (letrec ([p (cons a b)] 3991 [q (lambda (m) 3992 (if (< m u) 3993 (f m d) 3994 (h (car p))))]) 3995 (q (f a b))))]) 3996 (e u))))] 3997 [h (lambda (w) w)]) 3998 (f 4 5)) 3999 (letrec ((f (lambda (x) 4000 (+ x (((lambda (y) 4001 (lambda (z) 4002 (+ y z))) 4003 6)7)))) 4004 (g (+ 5 ((lambda (w u) (+ w u)) 8 9)))) 4005 g) 4006 ;; Jordan Johnson 4007 (let ((test (if (not (not 10)) #f 5))) 4008 (letrec ([num 5] 4009 [length 4010 (lambda (ls) 4011 (let ((len (if ((lambda (ck) (begin ck (set! num test) ck)) 4012 (null? ls)) 4013 (begin num (set! num 0) num) 4014 (begin (length '()) 4015 (set! num 5) 4016 (+ 1 (length (cdr ls))))))) 4017 (if len len)))]) 4018 (length (cons 5 (cons (if (set! num 50) (length (cons test '())) 1) 4019 '()))))) 4020 (letrec ([quotient (lambda (x y) 4021 (if (< x 0) 4022 (- 0 (quotient (- 0 x) y)) 4023 (if (< y 0) 4024 (- 0 (quotient x (- 0 y))) 4025 (letrec ([f (lambda (x a) 4026 (if (< x y) 4027 a 4028 (f (- x y) (+ a 1))))]) 4029 (f x 0)))))]) 4030 (letrec ([sub-interval 1] 4031 [sub-and-continue 4032 (lambda (n acc k) (k (- n sub-interval) (* n acc)))] 4033 [strange-fact 4034 (lambda (n acc) 4035 (if (zero? n) 4036 (lambda (proc) (proc acc)) 4037 (sub-and-continue n acc strange-fact)))]) 4038 (let ([x 20] 4039 [fact (let ((seed 1)) (lambda (n) (strange-fact n seed)))]) 4040 (let ([give-fact5-answer (fact 5)] 4041 [give-fact6-answer (fact 6)] 4042 [answer-user (lambda (ans) (quotient ans x))]) 4043 (set! x (give-fact5-answer answer-user)) 4044 (begin (set! x (give-fact6-answer answer-user)) 4045 x))))) 4046 (let ((y '()) 4047 (z 10)) 4048 (let ((test-ls (cons 5 y))) 4049 (set! y (lambda (f) 4050 ((lambda (g) (f (lambda (x) ((g g) x)))) 4051 (lambda (g) (f (lambda (x) ((g g) x))))))) 4052 (set! test-ls (cons z test-ls)) 4053 (letrec ((length (lambda (ls) 4054 (if (null? ls) 0 (+ 1 (length (cdr ls))))))) 4055 (let ((len (length test-ls))) 4056 (eq? (begin 4057 (set! length (y (lambda (len) 4058 (lambda (ls) 4059 (if (null? ls) 4060 0 4061 (+ 1 (len (cdr ls)))))))) 4062 (length test-ls)) 4063 len))))) 4064 ;; Ryan Newton 4065 (letrec 4066 ((loop 4067 (lambda () 4068 (lambda () 4069 (loop))))) 4070 (loop) 4071 0) 4072 (letrec ([f (lambda () 4073 (letrec ([loop 4074 (lambda (link) 4075 (lambda () 4076 (link)))]) 4077 (loop (lambda () 668))))]) 4078 ((f))) 4079 (if (lambda () 1) 4080 (let ((a 2)) 4081 (if (if ((lambda (x) 4082 (let ((x (set! a (set! a 1)))) 4083 x)) 1) 4084 (if (eq? a (void)) 4085 #t 4086 #f) 4087 #f) 4088 #36rgood ; dyb: cannot use symbols, so use radix 36 4089 #36rbad))) ; syntax to make all letters digits 4090 4091 ; contributed by Ryan Newton 4092 (letrec 4093 ( 4094 [dropsearch 4095 (lambda (cell tree) 4096 (letrec 4097 ([create-link 4098 (lambda (node f) 4099 (lambda (g) 4100 (if (not (pair? node)) 4101 (f g) 4102 (if (eq? node cell) 4103 #f 4104 (f (create-link (car node) 4105 (create-link (cdr node) g)))))))] 4106 [loop 4107 (lambda (link) 4108 (lambda () 4109 (if link 4110 (loop (link (lambda (v) v))) 4111 #f)))]) 4112 (loop (create-link tree (lambda (x) x))) 4113 ))] 4114 4115 [racethunks 4116 (lambda (thunkx thunky) 4117 (if (if thunkx thunky #f) 4118 (racethunks (thunkx) (thunky)) 4119 (if thunky 4120 #t 4121 (if thunkx 4122 #f 4123 '()))))] 4124 4125 [higher? 4126 (lambda (x y tree) 4127 (racethunks (dropsearch x tree) 4128 (dropsearch y tree)))] 4129 4130 [under? 4131 (lambda (x y tree) 4132 (racethunks (dropsearch x y) 4133 (dropsearch x tree)))] 4134 4135 [explore 4136 (lambda (x y tree) 4137 (if (not (pair? y)) 4138 #t 4139 (if (eq? x y) 4140 #f ;This will take out anything that points to itself 4141 (let ((result (higher? x y tree))) 4142 (if (eq? result #t) 4143 (if (explore y (car y) tree) 4144 (explore y (cdr y) tree) 4145 #f) 4146 (if (eq? result #f) 4147 (process-vertical-jump x y tree) 4148 (if (eq? result '()) 4149 (process-horizontal-jump x y tree) 4150 )))))))] 4151 4152 [process-vertical-jump 4153 (lambda (jumpedfrom jumpedto tree) 4154 (if 4155 (under? jumpedfrom jumpedto tree) 4156 #f 4157 (fullfinite? jumpedto)))] 4158 4159 [process-horizontal-jump 4160 (lambda (jumpedfrom jumpedto tree) 4161 (fullfinite? jumpedto))] 4162 4163 [fullfinite? 4164 (lambda (pair) 4165 (if (not (pair? pair)) 4166 #t 4167 (if (explore pair (car pair) pair) 4168 (explore pair (cdr pair) pair) 4169 #f)))]) 4170 (cons 4171 (fullfinite? (cons 1 2)) 4172 (cons 4173 (fullfinite? (let ((x (cons 1 2))) (set-car! x x) x)) 4174 (cons 4175 (fullfinite? (let ([a (cons 0 0)] [b (cons 0 0)] [c (cons 0 0)]) 4176 (set-car! a b) (set-cdr! a c) (set-cdr! b c) 4177 (set-car! b c) (set-car! c b) (set-cdr! c b) a)) 4178 '()))))) 4179 `(() 75 -2 -42 (0) ((0) 1) 32 ,(void) ,(void) 3 0 0 34 4 4180 142 2048 142 10 (#3(1 2 (3 #1(4))) #0() 3 #t) #f 0 #t 3 4181 3 3 3 0 0 9000 9000 17 (0) (0) 7 7 5000 0 #f #f 9000 3 4182 8000 4000 1 4 4 9000 9000 2 2 0 3 0 0 0 0 3 3 1 2 17 #f 4183 60 6 ((#t . -1) . 32) 3 ,(void) ,(void) ,(void) 0 4 0 0 4184 0 ,(void) 0 ,(void) 11 ,(void) 2 3050 2 3050 2050 2050 4185 700 0 0 0 #f 0 () 4 0 0 0 4 8000 2000 23 22 5061 1 1 4 4186 6 6 5 51 5 2 2 3 3 8 16 5 5 9 0 2 3 1 #t #t #t 120 (1) 4187 10 0 6400 6400 537516 8000 3000 63 120 10000 10000 8000 4188 24 35 #t 6 #t #f #f 1500 102 2600 60 5 5 5 5 5 8000 5 4189 1000 #f #t 120 144 3 3628800 3628800 4190 (52 44 17 22 38 . 3) (52 17 35 17 . 35) (3 . 42) #t 89 4191 89 37 4687 #t 48 176 5 1521 -1 (52 17 35 17 . 35) #f 4192 120 (120 . -120) #4(0 1 2 3) (3 . 6) 187 176 176 187 4193 (#t ((3 . 2) . 2) . 2) ((33 . 55) 77 . 99) 7 10 6 4194 (((3 21 18) 4 28 24) ((0 0 0) 1 7 6) (408 . 408)) 578 4195 (33 . #t) 4196 (#t . #38(#f 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #t 0)) 4197 3 3 (19 . #4(0 0 17 0)) (22 32 41 . 12) 4198 ((40 #f 105 15 . #t) #t 252 36 #t 9841 . 18) 35 9 22 2 4199 120 #t 0 668 778477 (#t #f #f))) 4200 (equal? 4201 (list 4202 ;;; Abdulaziz Ghuloum 4203 ;;; this is a vanilla insertion sort routine, not really interesting but used to 4204 ;;; derive the Y-Combinator version below. 4205 (letrec ([sort 4206 (lambda (p? ls) 4207 (if (null? ls) 4208 '() 4209 (insert p? (car ls) (sort p? (cdr ls)))))] 4210 [insert 4211 (lambda (p? x ls) 4212 (if (null? ls) 4213 (cons x '()) 4214 (if (p? x (car ls)) 4215 (cons x ls) 4216 (cons (car ls) (insert p? x (cdr ls))))))]) 4217 (sort (lambda (x y) (< x y)) '(4 3 2 5 6 3 6 9))) 4218 4219 ;;; and this is a more exotic insertion sort using double-Y-Combinator in order 4220 ;;; to stretch anonymous lambda expressions to their limit. Does it hurt yet? 4221 (((lambda (le) ; this is sort 4222 ((lambda (f) (f f)) 4223 (lambda (f) 4224 (le (lambda (p? ls) 4225 ((f f) p? ls)))))) 4226 (lambda (sort) 4227 (lambda (p? ls) 4228 (if (null? ls) 4229 '() 4230 (((lambda (le) ; this is insert 4231 ((lambda (f) (f f)) 4232 (lambda (f) 4233 (le (lambda (x ls) ((f f) x ls)))))) 4234 (lambda (insert) 4235 (lambda (x ls) 4236 (if (null? ls) 4237 (cons x '()) 4238 (if (p? x (car ls)) 4239 (cons x ls) 4240 (cons (car ls) (insert x (cdr ls)))))))) 4241 (car ls) (sort p? (cdr ls))))))) 4242 (lambda (x y) (< x y)) ; this is the sorting criterion 4243 '(4 3 2 5 6 3 6 9)) ; and the list to be sorted 4244 4245 ;;; this is a definition of a rotate procedure that rotates the elements of a 4246 ;;; list n times. It rotates the pair cells themselves and not the contents. 4247 ;;; It tests proper closure implementations in (set! x (cdr x)) as well as 4248 ;;; set-cdr! as it does not appear that frequently in tests.ss 4249 ;;; 4250 ;;; before 4251 ;;; +--+--+ +--+--+ +--+--+ +--+--+ +--+--+ +--+--+ 4252 ;;; | 1|------>| 2|------>| 3|------> ... | 6|------>| 7|------>| 8|#f| 4253 ;;; +--+--+ +--+--+ +--+--+ +--+--+ +--+--+ +--+--+ 4254 ;;; ^^ 4255 ;;; yx 4256 ;;; 4257 ;;; after 4258 ;;; +--+--+ +--+--+ +--+--+ +--+--+ +--+--+ +--+--+ 4259 ;;; | 4|------>| 5|------> ... | 8|------>| 1|------>| 2|------>| 3|#f| 4260 ;;; +--+--+ +--+--+ +--+--+ +--+--+ +--+--+ +--+--+ 4261 ;;; ^ ^ 4262 ;;; x y 4263 (let ([x (cons 1 (cons 2 (cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 '()))))))))]) 4264 (letrec ([rotate 4265 (lambda (n) 4266 (if (not (<= n 0)) 4267 (let ([s x]) 4268 (set! x (cdr x)) 4269 (insert s x) 4270 (rotate (- n 1)))))] 4271 [insert 4272 (lambda (s x) 4273 (if (null? (cdr x)) 4274 (begin 4275 (set-cdr! x s) 4276 (set-cdr! s '())) 4277 (insert s (cdr x))))]) 4278 (let ([y x]) 4279 (rotate 3) ; rotate x and chop y as a side effect 4280 (cons x (cons y '()))))) ; cons for comparison 4281 4282 ;;; Albert Hartono 4283 (letrec [(length 6) 4284 (start-value 6)] 4285 ((lambda (v lst) 4286 (letrec [(length (lambda (x) 4287 (if (null? x) 4288 0 4289 (add1 (length (cdr x))))))] 4290 (let [(ls-lg (length lst)) 4291 (v-lg (vector-length v))] 4292 (let [(new-vec (make-vector (+ ls-lg v-lg)))] 4293 (letrec [(loop-vec 4294 (lambda (index) 4295 (if (= index v-lg) 4296 (loop-ls lst index) 4297 (begin 4298 (vector-set! new-vec index (vector-ref v index)) 4299 (loop-vec (add1 index)))))) 4300 (loop-ls 4301 (lambda (lst index) 4302 (if (not (null? lst)) 4303 (begin 4304 (vector-set! new-vec index (car lst)) 4305 (loop-ls (cdr lst) (add1 index))))))] 4306 (loop-vec 0) 4307 new-vec))))) 4308 (let [(vec (letrec ([tmp-vec (lambda () (make-vector length))] 4309 [fill-vector 4310 (lambda (v lg val) 4311 (if (zero? lg) 4312 v 4313 (begin 4314 (vector-set! v (sub1 lg) val) 4315 (fill-vector v (sub1 lg) (add1 val)))))]) 4316 (fill-vector (tmp-vec) (vector-length (tmp-vec)) 4317 (- 0 start-value))))] 4318 vec) 4319 (letrec [(make-list (lambda (lg val) 4320 (if (not (zero? lg)) 4321 (cons val (make-list (sub1 lg) (sub1 val))) 4322 '())))] 4323 (make-list length start-value)))) 4324 4325 ;;; Brooke Chenoweth 4326 ;;; a little Ackermann, just for fun 4327 ;;; if you uncomment this, you should probably make most of the passes 4328 ;;; trusted, unless you want to wait a long time for it to complete. - rkd 4329 #;(let ([x 3] [y 6]) 4330 (letrec ([A (lambda (x y) 4331 (if (= x 0) 4332 (add1 y) 4333 (if (= y 0) 4334 (A (sub1 x) 1) 4335 (A (sub1 x) (A x (sub1 y))))))]) 4336 (A x y))) 4337 4338 ;;; let's try out a more substantial program 4339 ;;; the N queens problem, for several values of n 4340 ;;; solve-n-queens gives a list of the row indices for a valid queen placement, or #f if no solution 4341 (let ([n-vals '(1 2 3 4 5 6 7 8)]) 4342 (letrec ([solve-n-queens 4343 (lambda (n) 4344 (letrec ([extend-board 4345 (lambda (i b) 4346 (if (= i n) 4347 (let ([b (adjust b)]) 4348 (if b (extend-board 0 b) #f)) 4349 (if (valid? i b) 4350 (cons i b) 4351 (extend-board (+ i 1) b))))] 4352 [valid? 4353 (lambda (i b) 4354 (no-threat? (sub1 i) i (add1 i) b))] 4355 [no-threat? 4356 (lambda (u s d others) 4357 (if (null? others) 4358 #t 4359 (if (not (let ([neighbor (car others)]) 4360 (if (= neighbor u) 4361 #t 4362 (if (= neighbor s) 4363 #t 4364 (= neighbor d))))) 4365 (no-threat? (- u 1) s (+ d 1) (cdr others)) 4366 #f)))] 4367 [adjust 4368 (lambda (b) 4369 (if b 4370 (if (not (null? b)) 4371 (extend-board (add1 (car b)) (cdr b)) 4372 #f) 4373 #f))] 4374 [solve 4375 (lambda (len b) 4376 (if (= n len) 4377 b 4378 (solve (add1 len) (extend-board 0 b))))]) 4379 (solve 0 '())))]) 4380 (letrec ([test 4381 (lambda (ls) 4382 (if (null? ls) 4383 '() 4384 (let ([n (car ls)]) 4385 (cons (solve-n-queens n) 4386 (test (cdr ls))))))]) 4387 (test n-vals)))) 4388 4389 ;;; Ronald Garcia 4390 (let ([re-apply 4391 (lambda (high) 4392 (letrec ([gen 4393 (lambda (iter cont) 4394 (let ([cont1 (lambda (f val) (cont f (f val)))] 4395 [cont2 (lambda (f val) (cont f val))]) 4396 (if (= iter 0) 4397 cont2 4398 (gen (- iter 1) cont1))))]) 4399 (gen high (lambda (f val) val))))]) 4400 ((re-apply 10) (lambda (x) (+ x 1)) 5 )) 4401 4402 (let ([make-list 4403 (lambda (count) 4404 (letrec ([loop 4405 (lambda (val counter max) 4406 (if (= counter max) 4407 val 4408 (loop (cons counter val) (+ counter 1) max)))]) 4409 (loop '() 0 count)))]) 4410 (make-list 12)) 4411 4412 ;;; Jeremiah Willcock 4413 ;;; This test stresses two parts of the compiler: variable renaming and 4414 ;;; register allocation. It stresses the variable renaming mechanism by 4415 ;;; using locally-bound names that match special forms in the compiler. It 4416 ;;; stresses register allocation by having a large number of variables (and 4417 ;;; most of them are referenced). The actual code of the program is mostly a 4418 ;;; factorial function, but with many helper lambdas to deal with the lack of 4419 ;;; if. The list of set! statements had formerly set all variables up to z, 4420 ;;; but the list was trimmed so that it would compile using the compiler on 4421 ;;; the course Web page. The list of cons expressions at the bottom could 4422 ;;; also be extended to z. This program also has deeply nested expressions 4423 ;;; that will be simplified by remove-complex-opera*. It also contains a not 4424 ;;; expression in order to test the compiler's handling of this expression 4425 ;;; type, as well as a one-armed if expression and an implicit begin. 4426 (let ([ef (lambda (x y z) 4427 (let ([result z]) (if x (set! result y)) result))] 4428 [a 1] [b 2] [c 3] [d 4] [e 5] [f 6] [g 7] [h 8] [i 9] 4429 [j 10] [k 11] [l 12] [m 13] [n 14] [o 15] [p 16] [q 17] [r 18] 4430 [s 19] [t 20] [u 21] [v 22] [w 23] [x 24] [y 25] [z 26]) 4431 (set! a 0) 4432 (set! b 0) 4433 (set! c 0) 4434 (set! d 0) 4435 (set! e 0) 4436 (set! f 0) 4437 (set! g 0) 4438 (set! h 0) 4439 (set! i 0) 4440 (set! j 0) 4441 (set! k 0) 4442 (set! l 0) 4443 (set! m 0) 4444 (set! n 0) 4445 (set! o 0) 4446 (set! p 0) 4447 (letrec ([let 5] 4448 [letrec (lambda (x y) (set! let x) y)] 4449 [fac (lambda (n) ((ef (not (zero? n)) (f2 n) f1)))] 4450 [f1 (lambda () 1)] 4451 [f2 4452 ((lambda (f3) (lambda (n) (lambda () (* n (f3 n))))) 4453 (lambda (n) (fac (- n 1))))] 4454 [f3 (lambda (x) -1)] 4455 [if (lambda (x) (lambda () (+ 1 x)))]) 4456 ((lambda (lambda) 4457 (cons lambda 4458 (cons (fac let) 4459 (cons a (cons b (cons c (cons d (cons e (cons f 4460 (cons g (cons h (cons i (cons j (cons k (cons l 4461 (cons m (cons n (cons o '())))))))))))))))))) 4462 (letrec ([if 7]) ((if let)))))) 4463 4464 ;; This test uses streams of integers (similar to those studied in CSCI B521 4465 ;; and B621) to produce a list of integers that are not multiples of two and 4466 ;; five. It also has a heavy use of lambdas within the streams. This test 4467 ;; case will test closure conversion, most of its lambdas have references to 4468 ;; free variables. This program is purely functional, so it is much less of 4469 ;; a test of assignment conversion and begin handling than the last program. 4470 (letrec ([integers (lambda (n) (cons n (lambda () (integers (+ n 1)))))] 4471 [stream-times (lambda (s n) 4472 (cons (* (car s) n) 4473 (lambda () (stream-times ((cdr s)) n))))] 4474 [difference (lambda (s1 s2) 4475 (if (if (null? s1) #t (null? s2)) '() 4476 (if (< (car s1) (car s2)) 4477 (cons (car s1) (lambda () (difference ((cdr s1)) s2))) 4478 (if (= (car s1) (car s2)) 4479 (difference ((cdr s1)) ((cdr s2))) 4480 (difference s1 ((cdr s2)))))))] 4481 [stream-head (lambda (s n) 4482 (if (if (null? s) #t (zero? n)) '() 4483 (cons (car s) 4484 (if (= n 1) '() (stream-head ((cdr s)) (- n 1))))))]) 4485 (stream-head 4486 (difference 4487 (difference (integers 0) (stream-times (integers 0) 2)) 4488 (stream-times (integers 0) 5)) 4489 20)) 4490 4491 ;;; Mark Meiss 4492 ;;; Test out identifier defintions, scope of letrec, the poor man's 4493 ;;; Y-combinator, and higher-order procedures. 4494 (letrec ([odd (lambda (lambda odd) 4495 ((odd (lambda))))] 4496 [even (lambda (letrec lambda) 4497 (((((lambda letrec))))))]) 4498 (letrec ([uf (lambda (x y z) (if (x) y z))] 4499 [af (lambda (x y z) ((if x y z)))]) 4500 (letrec ([make-sub (lambda (sub) 4501 (lambda (n) (- n sub)))] 4502 [odd (lambda (odd even) 4503 (lambda (n) 4504 ((uf (lambda () (zero? n)) 4505 (lambda () #f) 4506 (lambda () ((even even odd) ((make-sub 1) n)))))))] 4507 [even (lambda (even odd) 4508 (lambda (n) 4509 (af (zero? n) 4510 (lambda () #t) 4511 (lambda () ((odd odd even) ((make-sub 1) n))))))]) 4512 ((even even odd) 12)))) 4513 4514 4515 ;;; Test out higher-order procedures and a mixture of tail and non-tail 4516 ;;; calls by playing around with a representation of Church numerals. 4517 (letrec ([zero (lambda (f) 4518 (lambda (x) x))] 4519 [succ (lambda (n) 4520 (lambda (f) 4521 (lambda (x) (f ((n f) x)))))] 4522 [zero? (lambda (n) 4523 ((n (lambda (x) #f)) #t))]) 4524 (letrec ([to-int (lambda (n) 4525 ((n (lambda (a) (+ a 1))) 0))] 4526 [from-int (lambda (n) 4527 (if (= n 0) zero (succ (from-int (- n 1)))))]) 4528 (letrec ([add (lambda (n) 4529 (lambda (m) ((n succ) m)))]) 4530 (- (+ 5 4) 4531 (to-int ((add (from-int 5)) (from-int 4))))))) 4532 4533 ;;; Matthew Garrett 4534 ;;; Bubble Sort on a list of numbers 4535 ;;; A recursive function defined inside a recursive function, both with the 4536 ;;; same name. 4537 (letrec ([list-length (lambda (ls) 4538 (letrec ([loop (lambda (ls n) 4539 (if (null? ls) 4540 n 4541 (loop (cdr ls) (+ n 1))))]) 4542 (loop ls 0)))] 4543 [sorted? (lambda (lon) 4544 (if (<= (list-length lon) 1) 4545 #t 4546 (if (< (car lon) (car (cdr lon))) 4547 (sorted? (cdr lon)) 4548 #f)))] 4549 [bubble-sort (lambda (lon) 4550 (if (sorted? lon) 4551 lon 4552 (bubble-sort (cdr 4553 ; cdr is necessary because of the "hold" place keeper, in this inner 4554 ; bubble-sort, which is guaranteed to get first place in this lesser to 4555 ; greater sorting. 4556 (letrec ([bubble-sort (lambda (hold list-of-numbers) 4557 (if (null? list-of-numbers) 4558 (cons hold '()) 4559 (if (< hold (car list-of-numbers)) 4560 (cons hold 4561 (bubble-sort 4562 (car list-of-numbers) 4563 (cdr list-of-numbers))) 4564 (cons (car list-of-numbers) 4565 (bubble-sort hold 4566 (cdr list-of-numbers))))))]) 4567 (bubble-sort 0 lon))))))]) 4568 (bubble-sort '(5 6 4 3 8 7)))) 4569 '((2 3 3 4 5 6 6 9) (2 3 3 4 5 6 6 9) 4570 ((4 5 6 7 8 1 2 3) (1 2 3)) 4571 #12(-1 -2 -3 -4 -5 -6 6 5 4 3 2 1) 4572 ((0) #f #f (2 0 3 1) (3 1 4 2 0) (4 2 0 5 3 1) 4573 (5 3 1 6 4 2 0) (3 1 6 2 5 7 4 0)) 4574 15 (11 10 9 8 7 6 5 4 3 2 1 0) 4575 (6 40320 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) 4576 (1 3 7 9 11 13 17 19 21 23 27 29 31 33 37 39 41 43 47 49) 4577 #t 0 (3 4 5 6 7 8))) 4578) 4579 4580(mat constant-closures 4581 ; make sure that closure optimization doesn't replicate closures 4582 (let ([f (rec f (lambda (q) f))]) 4583 (and 4584 (eq? f (f 3)) 4585 (eq? ((f 3) 4) (f 3)))) 4586 (begin 4587 (with-output-to-file "testfile-cc.ss" 4588 (lambda () 4589 (pretty-print 4590 '(define $cc-foo (rec f (lambda (q) f))))) 4591 'replace) 4592 (compile-file "testfile-cc") 4593 (load "testfile-cc.so") 4594 #t) 4595 (eq? ($cc-foo 3) $cc-foo) 4596 (eq? (($cc-foo 3) 4) $cc-foo) 4597) 4598 4599(mat simplify-if 4600 (eqv? 4601 (let ([x 'a] [y 'b]) 4602 (and (fixnum? x) (fixnum? (car y)))) 4603 #f) 4604 (eqv? 4605 (let ([x 'a] [y 'b]) 4606 (and (fixnum? x) (fixnum? (car y)) 75)) 4607 #f) 4608 (error? ; not a port 4609 (let ([x 'a]) 4610 (and (textual-port? x) (input-port? x)))) 4611 (not 4612 (let ([x 'a]) 4613 (and (input-port? x) (textual-port? x)))) 4614 (let ([x (current-input-port)]) 4615 (and (input-port? x) (textual-port? x))) 4616 (equal? 4617 (let () 4618 (define (? x) (and (input-port? x) (if (textual-port? x) #t (binary-port? x)))) 4619 (define-syntax first-value 4620 (syntax-rules () 4621 [(_ e) (let-values ([(x . r) e]) x)])) 4622 (list 4623 (? 'a) 4624 (? (open-string-input-port "")) 4625 (? (first-value (open-string-output-port))) 4626 (? (open-bytevector-input-port #vu8())) 4627 (? (first-value (open-bytevector-output-port))))) 4628 '(#f #t #f #t #f)) 4629) 4630 4631(mat virtual-registers 4632 (fixnum? (virtual-register-count)) 4633 (fx>= (virtual-register-count) 0) 4634 (error? ; invalid index 4635 (virtual-register 'one)) 4636 (error? ; invalid index 4637 (virtual-register -1)) 4638 (error? ; invalid index 4639 (virtual-register (+ (most-positive-fixnum) 1))) 4640 (error? ; invalid index 4641 (virtual-register 0.0)) 4642 (error? ; invalid index 4643 (set-virtual-register! 'one 19)) 4644 (error? ; invalid index 4645 (set-virtual-register! -1 19)) 4646 (error? ; invalid index 4647 (set-virtual-register! (+ (most-positive-fixnum) 1) 19)) 4648 (error? ; invalid index 4649 (set-virtual-register! 0.0 19)) 4650 (fx>= (virtual-register-count) 4) 4651 (eqv? (set-virtual-register! 3 'hello) (void)) 4652 (eqv? (virtual-register 3) 'hello) 4653 (eqv? 4654 (let ([x 3]) (virtual-register x)) 4655 'hello) 4656 (eqv? 4657 (let ([x 3] [y (cons 1 2)]) 4658 (set-virtual-register! x (list y))) 4659 (void)) 4660 (equal? (virtual-register 3) '((1 . 2))) 4661 (equal? 4662 (let () 4663 (define g (make-guardian)) 4664 (g (virtual-register 3)) 4665 (collect) 4666 (list (virtual-register 3) (g))) 4667 '(((1 . 2)) #f)) 4668) 4669 4670(mat pariah 4671 (error? ; invalid syntax 4672 (pariah)) 4673 (error? ; invalid syntax 4674 (pariah . 17)) 4675 (equal? 4676 (list (pariah 17)) 4677 '(17)) 4678 (equal? 4679 (let f ([n 10]) 4680 (if (fx= n 0) 4681 (pariah 1) 4682 (* n (f (fx- n 1))))) 4683 3628800) 4684 ; make sure that cp0 doesn't remove the pariah form 4685 (equivalent-expansion? 4686 (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) 4687 (expand/optimize 4688 '(if (zero? (random 1000)) 4689 (pariah (display 0)) 4690 (display 1)))) 4691 (if (= (optimize-level) 3) 4692 '(if (#3%zero? (#3%random 1000)) 4693 (begin (pariah (void)) (#3%display 0)) 4694 (#3%display 1)) 4695 '(if (#3%zero? (#2%random 1000)) 4696 (begin (pariah (void)) (#2%display 0)) 4697 (#2%display 1)))) 4698) 4699 4700(unless (memq (machine-type) '(arm32le tarm32le arm64le tarm64le arm64osx tarm64osx ; timestamp counter tends to be priviledged on Arm 4701 pb)) ; doesn't increment for pb 4702 (mat $read-time-stamp-counter 4703 4704 (let ([t (#%$read-time-stamp-counter)]) 4705 (and (integer? t) (exact? t))) 4706 4707 (let () 4708 ;; NB: pulled from thread.ms, to use as a delay 4709 (define fat+ 4710 (lambda (x y) 4711 (if (zero? y) 4712 x 4713 (fat+ (1+ x) (1- y))))) 4714 (define fatfib 4715 (lambda (x) 4716 (if (< x 2) 4717 1 4718 (fat+ (fatfib (1- x)) (fatfib (1- (1- x))))))) 4719 (let loop ([count 10] [success 0]) 4720 (if (fx= count 0) 4721 (>= success 9) 4722 (let ([t0 (#%$read-time-stamp-counter)]) 4723 (fatfib 26) 4724 (let ([t1 (#%$read-time-stamp-counter)]) 4725 (loop (fx- count 1) 4726 (if (< t0 t1) 4727 (fx+ success 1) 4728 success))))))) 4729 )) 4730 4731(mat procedure-arity-mask 4732 (equal? (procedure-arity-mask (lambda () #f)) 1) 4733 (equal? (procedure-arity-mask (lambda (x) x)) 2) 4734 (equal? (procedure-arity-mask (lambda (x y z w) x)) 16) 4735 (equal? (procedure-arity-mask (interpret '(lambda (x y z w) x))) 16) 4736 (or (eq? (current-eval) interpret) 4737 (equal? (procedure-arity-mask (lambda (x y z w a b c d e f g h i j) x)) (ash 1 14))) 4738 (or (eq? (current-eval) interpret) 4739 (equal? (procedure-arity-mask (interpret '(lambda (x y z w a b c d e f g h i j) x))) (ash 1 14))) 4740 (or (eq? (current-eval) interpret) 4741 (and 4742 (equal? (procedure-arity-mask (case-lambda)) 0) 4743 (equal? (procedure-arity-mask (case-lambda [(x) x] [(x y) y])) 6) 4744 (equal? (procedure-arity-mask (case-lambda [() x] [(x . y) y])) -1) 4745 (equal? (procedure-arity-mask (case-lambda [() x] [(x y . z) y])) (bitwise-not 2)) 4746 (equal? (procedure-arity-mask (case-lambda [(x y . z) y] [() x])) (bitwise-not 2)) 4747 (equal? (procedure-arity-mask (case-lambda [(x) x] [(x y) y] [(x y z) z])) 14))) 4748 (equal? (procedure-arity-mask list) -1) 4749 (equal? (procedure-arity-mask cons) 4) 4750 (equal? (procedure-arity-mask list*) (bitwise-not 1)) 4751 4752 (equal? (procedure-arity-mask +) -1) 4753 (equal? (procedure-arity-mask -) -2) 4754 (equal? (procedure-arity-mask max) -2) 4755 4756 (equal? (call/cc procedure-arity-mask) -1) 4757 (equal? (call/1cc procedure-arity-mask) -1) 4758 (equal? (procedure-arity-mask #%$null-continuation) 0) 4759 (equal? 4760 (parameterize ([enable-cp0 #t]) (compile '(procedure-arity-mask 4761 (case-lambda [a a] [(b) b])))) 4762 -1) 4763 (equal? 4764 (parameterize ([enable-cp0 #f]) (compile '(procedure-arity-mask 4765 (case-lambda [a a] [(b) b])))) 4766 -1) 4767 4768 (error? ; invalid argument 4769 (procedure-arity-mask 17)) 4770 ) 4771 4772 4773(mat procedure-name 4774 (begin 4775 (define (procedure-name f) 4776 (((inspect/object f) 'code) 'name)) 4777 (define (ok-name? name expect) 4778 (or (equal? name expect) 4779 ;; interpreter currently doesn't keep names 4780 (eq? (current-eval) interpret))) 4781 (define should-be-named-f (let ([f (lambda (x) x)]) f)) 4782 (define should-be-named-g (letrec ([g (lambda (x) x)]) g)) 4783 (define should-be-named-h (let ([f (let ([h (lambda (x) x)]) h)]) f)) 4784 (define should-be-named-i (letrec ([f (let ([i (lambda (x) x)]) i)]) f)) 4785 (define should-be-named-j (let ([f (letrec ([j (lambda (x) x)]) j)]) f)) 4786 (define (result-should-be-named-mk-CP) 4787 (let ([struct:CP (make-record-type-descriptor* 'CP #f #f #f #f 1 1)]) 4788 (let ([mk-CP (record-constructor (make-record-constructor-descriptor 4789 struct:CP #f #f))]) 4790 mk-CP))) 4791 #t) 4792 (ok-name? (procedure-name procedure-name) "procedure-name") 4793 (ok-name? (procedure-name should-be-named-f) "f") 4794 (ok-name? (procedure-name should-be-named-g) "g") 4795 (ok-name? (procedure-name should-be-named-h) "h") 4796 (ok-name? (procedure-name should-be-named-i) "i") 4797 (ok-name? (procedure-name should-be-named-j) "j") 4798 4799 (or (not (enable-cp0)) 4800 (#%$suppress-primitive-inlining) 4801 (let ([gx (make-guardian)]) 4802 (ok-name? (procedure-name gx) "gx"))) 4803 (or (not (enable-cp0)) 4804 (#%$suppress-primitive-inlining) 4805 (ok-name? (procedure-name (result-should-be-named-mk-CP)) "mk-CP")) 4806 4807 (or (not (enable-cp0)) 4808 (andmap ok-name? 4809 (map 4810 procedure-name 4811 (let ([f (lambda (g) 4812 (g (lambda (x) x)))]) 4813 (list (f (lambda (a) a)) 4814 (f (lambda (b) b))))) 4815 '("a" "b"))) 4816 ) 4817 4818 4819(mat wrapper-procedure 4820 (error? (make-wrapper-procedure)) 4821 (error? (make-wrapper-procedure (lambda args args))) 4822 (error? (make-wrapper-procedure (lambda args args) 1)) 4823 (error? (make-wrapper-procedure 1 1 #f)) 4824 (error? (make-wrapper-procedure 'not-a-procedure 1 #f)) 4825 (error? (make-wrapper-procedure (lambda args args) 'not-an-exact-integer #f)) 4826 (error? (make-wrapper-procedure (lambda args args) 1.0 #f)) 4827 4828 (error? (make-arity-wrapper-procedure)) 4829 (error? (make-arity-wrapper-procedure (lambda args args))) 4830 (error? (make-arity-wrapper-procedure (lambda args args) 1)) 4831 (error? (make-arity-wrapper-procedure 1 1 #f)) 4832 (error? (make-arity-wrapper-procedure 'not-a-procedure 1 #f)) 4833 (error? (make-arity-wrapper-procedure (lambda args args) 'not-an-exact-integer #f)) 4834 (error? (make-arity-wrapper-procedure (lambda args args) 1.0 #f)) 4835 4836 (equal? ((make-wrapper-procedure (lambda args args) 8 #f) 1 2 3) 4837 '(1 2 3)) 4838 (equal? ((make-wrapper-procedure (lambda args args) 1 #f) 1 2 3) ; arity not checked! 4839 '(1 2 3)) 4840 (equal? ((make-wrapper-procedure (lambda args args) (expt 2 100) #f) 1 2 3) ; arity not checked! 4841 '(1 2 3)) 4842 4843 (equal? ((make-arity-wrapper-procedure (lambda args args) 8 #f) 1 2 3) 4844 '(1 2 3)) 4845 (equal? ((make-arity-wrapper-procedure (lambda args args) (+ (expt 2 100) 8) #f) 1 2 3) 4846 '(1 2 3)) 4847 (error? ((make-arity-wrapper-procedure (lambda args args) 1 #f) 1 2 3)) 4848 (error? ((make-arity-wrapper-procedure (lambda args args) (expt 2 100) #f) 1 2 3)) 4849 (equal? (make-list 100 'ok) (apply (make-arity-wrapper-procedure (lambda args args) -1 #f) (make-list 100 'ok))) 4850 4851 (equal? (procedure-arity-mask (make-wrapper-procedure (lambda args args) 1 #f)) 4852 1) 4853 (equal? (procedure-arity-mask (make-wrapper-procedure (lambda args args) -12345 #f)) 4854 -12345) 4855 (equal? (procedure-arity-mask (make-wrapper-procedure (lambda args args) (expt 2 100) #f)) 4856 (expt 2 100)) 4857 4858 (equal? (procedure-arity-mask (make-arity-wrapper-procedure (lambda args args) 1 #f)) 4859 1) 4860 (equal? (procedure-arity-mask (make-arity-wrapper-procedure (lambda args args) -12345 #f)) 4861 -12345) 4862 (equal? (procedure-arity-mask (make-arity-wrapper-procedure (lambda args args) (expt 2 100) #f)) 4863 (expt 2 100)) 4864 4865 (not (wrapper-procedure? 10)) 4866 (not (wrapper-procedure? (lambda args args))) 4867 (not (wrapper-procedure? (interpret '(lambda args args)))) 4868 (wrapper-procedure? (make-wrapper-procedure (lambda args args) 1 #f)) 4869 (wrapper-procedure? (make-arity-wrapper-procedure (lambda args args) 1 #f)) 4870 4871 (error? (wrapper-procedure-data 1)) 4872 (error? (wrapper-procedure-data (lambda args args))) 4873 (error? (wrapper-procedure-data (interpret '(lambda args args)))) 4874 (equal? (wrapper-procedure-data (make-wrapper-procedure (lambda args args) 1 'data)) 4875 'data) 4876 (equal? (wrapper-procedure-data (make-arity-wrapper-procedure (lambda args args) 1 'data)) 4877 'data) 4878 4879 (error? (set-wrapper-procedure!)) 4880 (error? (set-wrapper-procedure! (make-arity-wrapper-procedure (lambda args args) 1 #f))) 4881 (error? (set-wrapper-procedure! 1 void)) 4882 (error? (set-wrapper-procedure! (lambda args args) void)) 4883 (error? (set-wrapper-procedure! (interpret '(lambda args args)) void)) 4884 (let ([p (make-wrapper-procedure (lambda args args) 8 #f)]) 4885 (set-wrapper-procedure! p vector) 4886 (equal? (p 1 2 3) 4887 '#(1 2 3))) 4888 (let ([p (make-arity-wrapper-procedure (lambda args args) 8 #f)]) 4889 (set-wrapper-procedure! p vector) 4890 (equal? (p 1 2 3) 4891 '#(1 2 3))) 4892 4893 (error? (set-wrapper-procedure-data!)) 4894 (error? (set-wrapper-procedure-data! (make-arity-wrapper-procedure (lambda args args) 1 #f))) 4895 (error? (set-wrapper-procedure-data! 1 #t)) 4896 (error? (set-wrapper-procedure-data! (lambda args args) #t)) 4897 (error? (set-wrapper-procedure-data! (interpret '(lambda args args)) #t)) 4898 (let ([p (make-wrapper-procedure (lambda args args) 8 'data)]) 4899 (set-wrapper-procedure-data! p 'other-data) 4900 (equal? (wrapper-procedure-data p) 4901 'other-data)) 4902 (let ([p (make-arity-wrapper-procedure (lambda args args) 8 'data)]) 4903 (set-wrapper-procedure-data! p 'other-data) 4904 (equal? (wrapper-procedure-data p) 4905 'other-data)) 4906 4907 (let ([a (make-wrapper-procedure (lambda args args) 8 #f)]) 4908 (lock-object a) 4909 (collect) 4910 (let ([g (gensym)]) 4911 (set-wrapper-procedure-data! a g) 4912 (collect) 4913 (and 4914 (equal? (wrapper-procedure-data a) g) 4915 (begin (unlock-object a) #t)))) 4916 (let ([a (make-arity-wrapper-procedure (lambda args args) 8 #f)]) 4917 (lock-object a) 4918 (collect) 4919 (let ([g (gensym)]) 4920 (set-wrapper-procedure-data! a g) 4921 (collect) 4922 (and 4923 (equal? (wrapper-procedure-data a) g) 4924 (begin (unlock-object a) #t)))) 4925 ) 4926 4927(mat fasl-immutable 4928 (begin 4929 (define immutable-objs (list (vector->immutable-vector '#(1 2 3)) 4930 (string->immutable-string "abc") 4931 (bytevector->immutable-bytevector #vu8(1 2 3)) 4932 (box-immutable 1) 4933 ;; Not immutable, but we want to test strip: 4934 (fxvector 1 2 3) 4935 (flvector 1.5 2.5 3.5) 4936 (stencil-vector 6 'a 'b))) 4937 (define immutable-zero-objs (list (vector->immutable-vector '#()) 4938 (string->immutable-string "") 4939 (bytevector->immutable-bytevector #vu8()) 4940 (box-immutable 1))) 4941 (define (immutable? l) 4942 (and (immutable-vector? (list-ref l 0)) 4943 (immutable-string? (list-ref l 1)) 4944 (immutable-bytevector? (list-ref l 2)) 4945 (immutable-box? (list-ref l 3)))) 4946 (define (round-trip l) 4947 (let-values ([(o get) (open-bytevector-output-port)]) 4948 (fasl-write l o) 4949 (immutable? (fasl-read (open-bytevector-input-port (get)))))) 4950 (define (round-trip-via-strip l) 4951 (compile-to-file (list `(set! fasl-immutable-round-trip ',l)) "testfile-immut-sff.so") 4952 (strip-fasl-file "testfile-immut-sff.so" "testfile-immut-sff.so" (fasl-strip-options)) 4953 (load "testfile-immut-sff.so") 4954 (let ([l2 (eval 'fasl-immutable-round-trip)]) 4955 (and (equal? l l2) 4956 (immutable? l2)))) 4957 (define (round-trip-symbol sym) 4958 (let-values ([(o get) (open-bytevector-output-port)]) 4959 (fasl-write sym o) 4960 (let ([s (fasl-read (open-bytevector-input-port (get)))]) 4961 (and (symbol? s) 4962 (immutable-string? (symbol->string s)) 4963 (or (not (gensym? s)) 4964 (immutable-string? (gensym->unique-string s))))))) 4965 #t) 4966 4967 (immutable? immutable-objs) 4968 (immutable? immutable-zero-objs) 4969 (round-trip immutable-objs) 4970 (round-trip immutable-zero-objs) 4971 (round-trip-via-strip immutable-objs) 4972 (round-trip-via-strip immutable-zero-objs) 4973 4974 (round-trip-symbol 'hello) 4975 (round-trip-symbol (string->symbol "hola")) 4976 (round-trip-symbol (gensym "bonjour")) 4977 4978 ;; Make sure `fasl-read` didn't mark "mutable" null values 4979 ;; as immutable: 4980 (mutable-vector? '#()) 4981 (mutable-string? "") 4982 (mutable-bytevector? '#vu8()) 4983 4984 ) 4985 4986(mat show-allocation 4987 (begin 4988 (#%$show-allocation #t) 4989 #t) 4990) 4991 4992(mat current-generate-id 4993 (begin 4994 (define (make-x-generator) 4995 (let ([x-uid "gf91a5b83ujz3mogjdaij7-x"] 4996 [counter-ht (make-eq-hashtable)]) 4997 (lambda (sym) 4998 (let* ([n (eq-hashtable-ref counter-ht sym 0)] 4999 [str (if (gensym? sym) (gensym->unique-string sym) (symbol->string sym))] 5000 [g (gensym (symbol->string sym) (format "~a-~a-~a" x-uid str n))]) 5001 (eq-hashtable-set! counter-ht sym (+ n 1)) 5002 g)))) 5003 (and (parameterize ([current-generate-id (make-x-generator)]) 5004 (eval `(module consistent-x (x make-pt pt-r) 5005 ;; Note: `module` doesn't currently enable `x` to be inlined 5006 (define x 1) 5007 (define-record-type pt (fields r i))))) 5008 #t)) 5009 (begin 5010 (define return-x (let () 5011 (import consistent-x) 5012 (lambda () x))) 5013 (define a-pt (let () 5014 (import consistent-x) 5015 (make-pt -1 -2))) 5016 (define get-r (let () 5017 (import consistent-x) 5018 (lambda (p) (pt-r p)))) 5019 (equal? 1 (return-x))) 5020 (equal? -1 (get-r a-pt)) 5021 (begin 5022 (parameterize ([current-generate-id (make-x-generator)]) 5023 (eval `(module consistent-x (x make-pt pt-x) 5024 (define x 2) 5025 (define-record-type pt (fields x y))))) 5026 (equal? 2 (return-x))) 5027 (equal? -1 (get-r a-pt)) 5028 (begin 5029 (parameterize ([current-generate-id (make-x-generator)]) 5030 (eval `(module consistent-x (x) 5031 (define x 3) 5032 (define-syntax def (syntax-rules () [(_) (define x 'other)])) 5033 ;; `(def)` after above definition => expect that 5034 ;; its `x` is generated second 5035 (def)))) 5036 (equal? 3 (return-x))) 5037) 5038 5039(mat expand-omit-library-invocations 5040 (not (expand-omit-library-invocations)) 5041 (begin 5042 (library (define-m-as-one) (export m) (import (chezscheme)) (define m 1)) 5043 (define (find-define-m-as-one s) 5044 (or (eq? s 'define-m-as-one) 5045 (and (pair? s) 5046 (or (find-define-m-as-one (car s)) 5047 (find-define-m-as-one (cdr s)))))) 5048 #t) 5049 (find-define-m-as-one (expand '(let () (import (define-m-as-one)) m))) 5050 (begin 5051 (expand-omit-library-invocations 'yes) 5052 (eq? #t (expand-omit-library-invocations))) 5053 (not (find-define-m-as-one (expand '(let () (import (define-m-as-one)) m)))) 5054 (begin 5055 (expand-omit-library-invocations #f) 5056 (not (expand-omit-library-invocations))) 5057 (find-define-m-as-one (expand '(let () (import (define-m-as-one)) m))) 5058) 5059 5060(mat enable-unsafe-application 5061 (begin 5062 (define (get-uncprep-form e) 5063 (let ([r #f]) 5064 (parameterize ([run-cp0 (lambda (cp0 e) 5065 (parameterize ([enable-unsafe-application #f]) 5066 (set! r (#%$uncprep e))) 5067 e)]) 5068 (expand/optimize e)) 5069 r)) 5070 #t) 5071 (equivalent-expansion? (get-uncprep-form '(lambda (x) (x))) 5072 '(lambda (x) (x))) 5073 (equivalent-expansion? (parameterize ([enable-unsafe-application #t]) 5074 (get-uncprep-form '(lambda (x) (x)))) 5075 (if (= 3 (optimize-level)) 5076 '(lambda (x) (x)) 5077 '(lambda (x) (#3%$app x)))) 5078 ) 5079 5080(mat enable-unsafe-variable-reference 5081 (begin 5082 (define (get-uncprep-form e) 5083 (let ([r #f]) 5084 (parameterize ([run-cp0 (lambda (cp0 e) 5085 (set! r (#%$uncprep e)) 5086 e)]) 5087 (expand/optimize e)) 5088 r)) 5089 #t) 5090 (equivalent-expansion? (parameterize ([#%$suppress-primitive-inlining #f]) 5091 (get-uncprep-form '(lambda (x) (letrec ([y y]) (+ y x))))) 5092 (if (= 3 (optimize-level)) 5093 '(lambda (x) 5094 (letrec ([y y]) 5095 (#3%+ y x))) 5096 '(lambda (x) 5097 (let ([valid? #f]) 5098 (letrec ([y (begin 5099 (if valid? 5100 (#2%void) 5101 (#2%$source-violation #f #f #t "attempt to reference undefined variable ~s" 'y)) 5102 y)]) 5103 (set! valid? #t) 5104 (#2%+ y x)))))) 5105 (equivalent-expansion? (parameterize ([enable-unsafe-variable-reference #t] 5106 [#%$suppress-primitive-inlining #f]) 5107 (get-uncprep-form '(lambda (x) (letrec ([y y]) (+ y x))))) 5108 (if (= 3 (optimize-level)) 5109 '(lambda (x) 5110 (letrec ([y y]) 5111 (#3%+ y x))) 5112 '(lambda (x) 5113 (letrec ([y y]) 5114 (#2%+ y x))))) 5115 ) 5116 5117(mat phantom-bytevector 5118 (phantom-bytevector? (make-phantom-bytevector 0)) 5119 (not (phantom-bytevector? 10)) 5120 (not (phantom-bytevector? (vector 1 2 3))) 5121 5122 (error? (make-phantom-bytevector -1)) 5123 (error? (make-phantom-bytevector (expt 2 100))) 5124 (error? (make-phantom-bytevector 'x)) 5125 5126 (begin 5127 (define $ph (make-phantom-bytevector 0)) 5128 (phantom-bytevector? $ph)) 5129 (eqv? 0 (phantom-bytevector-length $ph)) 5130 (eqv? (void) (set-phantom-bytevector-length! $ph 1)) 5131 (eqv? 1 (phantom-bytevector-length $ph)) 5132 (eqv? (void) (set-phantom-bytevector-length! $ph 100)) 5133 (eqv? 100 (phantom-bytevector-length $ph)) 5134 5135 (begin 5136 (collect (collect-maximum-generation)) 5137 (define $pre-allocated (bytes-allocated)) 5138 (define $pre-memory (current-memory-bytes)) 5139 (set-phantom-bytevector-length! $ph $pre-allocated) 5140 #t) 5141 5142 ;; Big change to `(bytes-allocated)` 5143 (< (* 1.75 $pre-allocated) 5144 (bytes-allocated) 5145 (* 2.25 $pre-allocated)) 5146 5147 ;; Big change to `(current-memory-bytes)` 5148 (< (+ (* 0.75 $pre-allocated) 5149 $pre-memory) 5150 (current-memory-bytes) 5151 (+ (* 1.25 $pre-memory) 5152 $pre-memory)) 5153 5154 ;; Same change after GC 5155 (begin 5156 (collect (collect-maximum-generation)) 5157 (< (* 1.75 $pre-allocated) 5158 (bytes-allocated) 5159 (* 2.25 $pre-allocated))) 5160 5161 ;; fasl => another jump by `$pre-allocated` bytes 5162 (begin 5163 (define $ph2 5164 (let-values ([(o get) (open-bytevector-output-port)]) 5165 (fasl-write $ph o) 5166 (fasl-read (open-bytevector-input-port (get))))) 5167 (phantom-bytevector? $ph2)) 5168 5169 (< (* 2.75 $pre-allocated) 5170 (bytes-allocated) 5171 (* 3.25 $pre-allocated)) 5172 5173 ;; Try GC again 5174 (begin 5175 (collect (collect-maximum-generation)) 5176 (< (* 2.75 $pre-allocated) 5177 (bytes-allocated) 5178 (* 3.25 $pre-allocated))) 5179 5180 ;; Let GC reclaim $ph2, and `(byte-allocated)` should go down 5181 (begin 5182 (set! $ph2 #f) 5183 (collect (collect-maximum-generation)) 5184 (< (* 1.75 $pre-allocated) 5185 (bytes-allocated) 5186 (* 2.25 $pre-allocated))) 5187 5188 (> (compute-size $ph) (phantom-bytevector-length $ph)) 5189 5190 ;; Change length of `$ph`, and `(byte-allocated)` should go down 5191 (begin 5192 (set-phantom-bytevector-length! $ph 0) 5193 (< (* 0.75 $pre-allocated) 5194 (bytes-allocated) 5195 (* 1.25 $pre-allocated))) 5196 ) 5197 5198(mat immobile 5199 (error? (box-immobile)) 5200 (error? (box-immobile 1 2)) 5201 5202 (error? (make-immobile-vector)) 5203 (error? (make-immobile-vector 'a)) 5204 (error? (make-immobile-vector -10)) 5205 (error? (make-immobile-vector (expt 2 100))) 5206 (error? (make-immobile-vector 10 1 2)) 5207 5208 (error? (make-immobile-bytevector)) 5209 (error? (make-immobile-bytevector 'a)) 5210 (error? (make-immobile-byte-vector -10)) 5211 (error? (make-immobile-bytevector (expt 2 100))) 5212 (error? (make-immobile-bytevector 10 1024)) 5213 (error? (make-immobile-bytevector 10 1 2)) 5214 5215 (box? (box-immobile 10)) 5216 (vector? (make-immobile-vector 10)) 5217 (eqv? 0 (vector-ref (make-immobile-vector 10) 9)) 5218 (bytevector? (make-immobile-bytevector 10)) 5219 (eqv? 0 (bytevector-u8-ref (make-immobile-bytevector 10 0) 9)) 5220 5221 (begin 5222 (define (make-objects) 5223 (let loop ([i 16]) 5224 (cond 5225 [(zero? i) '()] 5226 [else 5227 (let* ([b (box-immobile (format "box ~a" i))] 5228 [b-addr (#%$fxaddress b)] 5229 [v (make-immobile-vector (expt 2 i) b)] 5230 [v-addr (#%$fxaddress v)] 5231 [s (make-immobile-bytevector (expt 2 i) i)] 5232 [s-addr (#%$fxaddress s)]) 5233 (cons (list i 5234 b b-addr 5235 v v-addr 5236 s s-addr) 5237 (loop (sub1 i))))]))) 5238 (define (check-objects l) 5239 (let loop ([l l]) 5240 (or (null? l) 5241 (let-values ([(i b b-addr v v-addr s s-addr) (apply values (car l))]) 5242 (and (equal? (format "box ~a" i) (unbox b)) 5243 (equal? (format "box ~a" i) (unbox (vector-ref v (sub1 (vector-length v))))) 5244 (eqv? i (bytevector-u8-ref s (sub1 (bytevector-length s)))) 5245 (eqv? b-addr (#%$fxaddress b)) 5246 (eqv? v-addr (#%$fxaddress v)) 5247 (eqv? s-addr (#%$fxaddress s)) 5248 (loop (cdr l))))))) 5249 (define (mutate-objects l) 5250 (let loop ([l l]) 5251 (or (null? l) 5252 (let-values ([(i b b-addr v v-addr s s-addr) (apply values (car l))]) 5253 (set-box! b (format "box ~a" i)) 5254 (vector-set! v (sub1 (vector-length v)) (box (unbox b))) 5255 (loop (cdr l)))))) 5256 #t) 5257 5258 (with-interrupts-disabled 5259 (let ([objs (make-objects)]) 5260 (and (check-objects objs) 5261 (begin 5262 (collect 0 1) 5263 (and 5264 (check-objects objs) 5265 (begin 5266 (mutate-objects objs) 5267 (collect 0 0) 5268 (and 5269 (check-objects objs) 5270 (begin 5271 (collect (collect-maximum-generation)) 5272 (check-objects objs))))))))) 5273 5274 (or 5275 (not (threaded?)) 5276 (let ([m (make-mutex)] 5277 [c (make-condition)] 5278 [running 4]) 5279 (let thread-loop ([t running]) 5280 (unless (= t 0) 5281 (fork-thread 5282 (lambda () 5283 (let loop ([i 1000] [objs '()] [addrs '()]) 5284 (cond 5285 [(= i 0) 5286 (mutex-acquire m) 5287 (set! running (sub1 running)) 5288 (condition-signal c) 5289 (mutex-release m)] 5290 [else 5291 (let ([v (case (modulo i 3) 5292 [(0) (box-immobile objs)] 5293 [(1) (make-immobile-vector i objs)] 5294 [(2) (make-immobile-bytevector i)])]) 5295 (let ([objs (cons v objs)] 5296 [addrs (cons (#%$fxaddress v) addrs)]) 5297 (collect-rendezvous) 5298 (let check ([objs objs] [addrs addrs]) 5299 (unless (null? objs) 5300 (let ([v (car objs)]) 5301 (unless (= (#%$fxaddress v) (car addrs)) 5302 (error 'immobile "address changed: ~s" v)) 5303 (cond 5304 [(box? v) 5305 (unless (eq? (unbox v) (cdr objs)) 5306 (error 'immobile "bad box content"))] 5307 [(vector? v) 5308 (let loop ([j 0]) 5309 (unless (= j (vector-length v)) 5310 (unless (eq? (cdr objs) (vector-ref v j)) 5311 (error 'immobile "bad vector content")) 5312 (loop (add1 j))))] 5313 [(bytevector? v) 5314 (void)] 5315 [else 5316 (error 'immobile "bad object: ~s" v)])) 5317 (check (cdr objs) (cdr addrs)))) 5318 (loop (sub1 i) objs addrs)))])))) 5319 (thread-loop (sub1 t)))) 5320 (mutex-acquire m) 5321 (let loop () 5322 (unless (= running 0) 5323 (condition-wait c m) 5324 (loop))) 5325 (mutex-release m) 5326 ;; Wait for threads to exit 5327 (let () 5328 (define $threads (foreign-procedure "(cs)threads" () scheme-object)) 5329 (let loop () 5330 (unless (= 1 (length ($threads))) 5331 (sleep (make-time 'time-duration 10000 0)) 5332 (loop)))) 5333 #t)) 5334 5335 ) 5336 5337(mat compacting 5338 ;; try to provoke the GC into putting a record into marked 5339 ;; (instead of copied) space and check the write barrier there 5340 (let loop ([N 2]) 5341 (or (= N 8192) 5342 (let sel-loop ([sels (list car cadr)]) 5343 (cond 5344 [(null? sels) (loop (* N 2))] 5345 [else 5346 (let () 5347 (define rtd (make-record-type 5348 "r" 5349 (let loop ([i N]) 5350 (if (zero? i) 5351 (list '[ptr y]) 5352 (cons `[uptr ,(string->symbol (format "x~a" i))] 5353 (loop (sub1 i))))))) 5354 5355 (define (make-r) 5356 (apply (record-constructor rtd) 5357 (let loop ([i N]) 5358 (if (zero? i) 5359 '(the-y-value) 5360 (cons 0 (loop (sub1 i))))))) 5361 5362 (define r-y (record-accessor rtd N)) 5363 (define set-r-y! (record-mutator rtd N)) 5364 5365 (define rs (list (make-r) 5366 (make-r) 5367 (make-r))) 5368 (collect (collect-maximum-generation)) 5369 (set! rs (list (car rs) (caddr rs))) 5370 (collect (collect-maximum-generation)) 5371 (set-r-y! ((car sels) rs) (string-copy "new-string-to-go")) 5372 (collect) 5373 (and (equal? (r-y ((car sels) rs)) 5374 "new-string-to-go") 5375 (sel-loop (cdr sels))))])))) 5376 ) 5377