1;;; 7.ss 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;;; system operations 17 18(begin 19(define scheme-start 20 (make-parameter 21 (lambda fns (for-each load fns) (new-cafe)) 22 (lambda (p) 23 (unless (procedure? p) 24 ($oops 'scheme-start "~s is not a procedure" p)) 25 p))) 26 27(define scheme-script 28 (make-parameter 29 (lambda (fn . fns) 30 (command-line (cons fn fns)) 31 (command-line-arguments fns) 32 (load fn)) 33 (lambda (p) 34 (unless (procedure? p) 35 ($oops 'scheme-script "~s is not a procedure" p)) 36 p))) 37 38(define scheme-program 39 (make-parameter 40 (lambda (fn . fns) 41 (command-line (cons fn fns)) 42 (command-line-arguments fns) 43 (load-program fn)) 44 (lambda (p) 45 (unless (procedure? p) 46 ($oops 'scheme-program "~s is not a procedure" p)) 47 p))) 48 49(define command-line-arguments 50 (make-parameter 51 '() 52 (lambda (x) 53 (unless (and (list? x) (andmap string? x)) 54 ($oops 'command-line-arguments "~s is not a list of strings" x)) 55 x))) 56 57(define command-line 58 (make-parameter 59 '("") 60 (lambda (x) 61 (unless (and (list? x) (not (null? x)) (andmap string? x)) 62 ($oops 'command-line "~s is not a nonempty list of strings" x)) 63 x))) 64 65(define-who #(r6rs: command-line) 66 (lambda () 67 (#2%command-line))) 68 69(define-who bytes-allocated 70 (let ([ba (foreign-procedure "(cs)bytes_allocated" 71 (scheme-object scheme-object) 72 scheme-object)]) 73 (define filter-generation 74 (lambda (g) 75 (cond 76 [(and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) g] 77 [(eq? g 'static) (constant static-generation)] 78 [else ($oops who "invalid generation ~s" g)]))) 79 (define filter-space 80 (lambda (s) 81 (cond 82 [(assq s (constant real-space-alist)) => cdr] 83 [else ($oops who "invalid space ~s" s)]))) 84 (case-lambda 85 [() (ba -1 -1)] 86 [(g) (ba (filter-generation g) -1)] 87 [(g s) (ba (if g (filter-generation g) -1) (if s (filter-space s) -1))]))) 88 89(define $spaces (lambda () (map car (constant real-space-alist)))) 90 91(define current-memory-bytes (foreign-procedure "(cs)curmembytes" () uptr)) 92(define maximum-memory-bytes (foreign-procedure "(cs)maxmembytes" () uptr)) 93 94(define reset-maximum-memory-bytes! (foreign-procedure "(cs)resetmaxmembytes" () void)) 95 96(define-who with-source-path 97 (lambda (whoarg fn p) 98 (unless (or (eq? whoarg #f) (string? whoarg) (symbol? whoarg)) ($oops who "invalid who argument ~s" whoarg)) 99 (unless (string? fn) ($oops who "~s is not a string" fn)) 100 (unless (procedure? p) ($oops who "~s is not a procedure" p)) 101 (let ([dirs (source-directories)]) 102 (if (or (equal? dirs '("")) (equal? dirs '(".")) ($fixed-path? fn)) 103 (p fn) 104 (let loop ([ls dirs]) 105 (if (null? ls) 106 ($oops whoarg "file ~s not found in source directories" fn) 107 (let ([path (let ([dir (car ls)]) 108 (if (or (string=? dir "") (string=? dir ".")) 109 fn 110 (format 111 (if (directory-separator? 112 (string-ref dir 113 (fx- (string-length dir) 1))) 114 "~a~a" 115 "~a/~a") 116 dir fn)))]) 117 (if (guard (c [#t #f]) (close-input-port (open-input-file path)) #t) 118 (p path) 119 (loop (cdr ls)))))))))) 120 121(set! $compressed-warning 122 (let ([warned? #f]) 123 (lambda (who p) 124 (unless warned? 125 (set! warned? #t) 126 (warningf who "fasl file content is compressed internally; compressing the file (~s) is redundant and can slow fasl writing and reading significantly" p))))) 127 128(set-who! fasl-read 129 (let () 130 (define $fasl-read (foreign-procedure "(cs)fasl_read" (int fixnum ptr) ptr)) 131 (define $bv-fasl-read (foreign-procedure "(cs)bv_fasl_read" (ptr ptr) ptr)) 132 (define (get-uptr p) 133 (let ([k (get-u8 p)]) 134 (let f ([k k] [n (fxsrl k 1)]) 135 (if (fxlogbit? 0 k) 136 (let ([k (get-u8 p)]) 137 (f k (logor (ash n 7) (fxsrl k 1)))) 138 n)))) 139 (define (get-uptr/bytes p) 140 (let ([k (get-u8 p)]) 141 (let f ([k k] [n (fxsrl k 1)] [bytes 1]) 142 (if (fxlogbit? 0 k) 143 (let ([k (get-u8 p)]) 144 (f k (logor (ash n 7) (fxsrl k 1)) (fx+ bytes 1))) 145 (values n bytes))))) 146 (define (malformed p what) ($oops who "malformed fasl-object found in ~s (~a)" p what)) 147 (define (check-header p) 148 (let ([bv (make-bytevector 8 (constant fasl-type-header))]) 149 (unless (and (eqv? (get-bytevector-n! p bv 1 7) 7) 150 (bytevector=? bv (constant fasl-header))) 151 (malformed p "invalid header"))) 152 (let ([n (get-uptr p)]) 153 (unless (= n (constant scheme-version)) 154 ($oops who "incompatible fasl-object version ~a found in ~s" 155 ($format-scheme-version n) p))) 156 (let ([n (get-uptr p)]) 157 (unless (or (= n (constant machine-type-any)) (= n (constant machine-type))) 158 (cond 159 [(assv n (constant machine-type-alist)) => 160 (lambda (a) 161 ($oops who "incompatible fasl-object machine-type ~s found in ~s" 162 (cdr a) p))] 163 [else (malformed p "unrecognized machine type")]))) 164 (unless (and (eqv? (get-u8 p) (char->integer #\()) ;) 165 (let f () 166 (let ([n (get-u8 p)]) 167 (and (not (eof-object? n)) ;( 168 (or (eqv? n (char->integer #\))) (f)))))) 169 (malformed p "invalid list of base boot files"))) 170 (define (go p situation) 171 (define (go1) 172 (if (and ($port-flags-set? p (constant port-flag-file)) 173 (or (not ($port-flags-set? p (constant port-flag-compressed))) 174 (begin ($compressed-warning who p) #f)) 175 (eqv? (binary-port-input-count p) 0)) 176 ($fasl-read ($port-info p) situation (port-name p)) 177 (let fasl-entry () 178 (let ([ty (get-u8 p)]) 179 (cond 180 [(eof-object? ty) ty] 181 [(eqv? ty (constant fasl-type-header)) 182 (check-header p) 183 (fasl-entry)] 184 [(eqv? ty (constant fasl-type-visit)) 185 (go2 (eqv? situation (constant fasl-type-revisit)))] 186 [(eqv? ty (constant fasl-type-revisit)) 187 (go2 (eqv? situation (constant fasl-type-visit)))] 188 [(eqv? ty (constant fasl-type-visit-revisit)) 189 (go2 #f)] 190 [else (malformed p "invalid situation")]))))) 191 (define (go2 skip?) 192 (let ([n (get-uptr p)]) 193 (if skip? 194 (begin 195 (if (and (port-has-port-position? p) (port-has-set-port-position!? p)) 196 (set-port-position! p (+ (port-position p) n)) 197 (get-bytevector-n p n)) 198 (go1)) 199 (let ([compressed-flag (get-u8 p)]) 200 (cond 201 [(or (eqv? compressed-flag (constant fasl-type-gzip)) (eqv? compressed-flag (constant fasl-type-lz4))) 202 (let-values ([(dest-size dest-size-bytes) (get-uptr/bytes p)]) 203 (let* ([src-size (- n 1 dest-size-bytes)] 204 [bv (get-bytevector-n p src-size)] 205 [bv ($bytevector-uncompress bv dest-size 206 (if (eqv? compressed-flag (constant fasl-type-gzip)) 207 (constant COMPRESS-GZIP) 208 (constant COMPRESS-LZ4)))]) 209 ($bv-fasl-read bv (port-name p))))] 210 [(eqv? compressed-flag (constant fasl-type-uncompressed)) 211 ($bv-fasl-read (get-bytevector-n p (- n 1)) (port-name p))] 212 [else (malformed p "invalid compression")]))))) 213 (unless (and (input-port? p) (binary-port? p)) 214 ($oops who "~s is not a binary input port" p)) 215 (go1)) 216 (case-lambda 217 [(p) (go p (constant fasl-type-visit-revisit))] 218 [(p situation) 219 (go p 220 (case situation 221 [(visit) (constant fasl-type-visit)] 222 [(revisit) (constant fasl-type-revisit)] 223 [(load) (constant fasl-type-visit-revisit)] 224 [else ($oops who "invalid situation ~s" situation)]))]))) 225 226(define ($compiled-file-header? ip) 227 (let ([pos (port-position ip)]) 228 (let ([cfh? (let* ([bv (constant fasl-header)] [n (bytevector-length bv)]) 229 (let f ([i 0]) 230 (or (fx= i n) 231 (and (eqv? (get-u8 ip) (bytevector-u8-ref bv i)) 232 (f (fx+ i 1))))))]) 233 (set-port-position! ip pos) 234 cfh?))) 235 236(let () 237 (define do-load-binary 238 (lambda (who fn ip situation for-import? importer) 239 (let ([load-binary (make-load-binary who fn situation for-import? importer)]) 240 (let ([x (fasl-read ip situation)]) 241 (unless (eof-object? x) 242 (let loop ([x x]) 243 (let ([next-x (fasl-read ip situation)]) 244 (if (eof-object? next-x) 245 (load-binary x) 246 (begin (load-binary x) (loop next-x)))))))))) 247 248 (define (make-load-binary who fn situation for-import? importer) 249 (module (Lexpand? recompile-info? library/ct-info? library/rt-info? program-info?) 250 (import (nanopass)) 251 (include "base-lang.ss") 252 (include "expand-lang.ss")) 253 (lambda (x) 254 (cond 255 [(procedure? x) (x)] 256 [(library/rt-info? x) ($install-library/rt-desc x for-import? importer fn)] 257 [(library/ct-info? x) ($install-library/ct-desc x for-import? importer fn)] 258 [(program-info? x) ($install-program-desc x)] 259 [(recompile-info? x) (void)] 260 [(Lexpand? x) ($interpret-backend x situation for-import? importer fn)] 261 ; NB: this is here to support the #t inserted by compile-file-help2 after header information 262 [(eq? x #t) (void)] 263 [else ($oops who "unexpected value ~s read from ~a" x fn)]))) 264 265 (define (do-load who fn situation for-import? importer ksrc) 266 (let ([ip ($open-file-input-port who fn)]) 267 (on-reset (close-port ip) 268 (let ([fp (let ([start-pos (port-position ip)]) 269 (if (and (eqv? (get-u8 ip) (char->integer #\#)) 270 (eqv? (get-u8 ip) (char->integer #\!)) 271 (let ([b (get-u8 ip)]) (or (eqv? b (char->integer #\space)) (eqv? b (char->integer #\/))))) 272 (let loop ([fp 3]) 273 (let ([b (get-u8 ip)]) 274 (if (eof-object? b) 275 fp 276 (let ([fp (+ fp 1)]) 277 (if (eqv? b (char->integer #\newline)) 278 fp 279 (loop fp)))))) 280 (begin (set-port-position! ip start-pos) 0)))]) 281 (if ($compiled-file-header? ip) 282 (begin 283 (do-load-binary who fn ip situation for-import? importer) 284 (close-port ip)) 285 (begin 286 (unless ksrc 287 (close-port ip) 288 ($oops who "~a is not a compiled file" fn)) 289 (unless (eqv? fp 0) (set-port-position! ip 0)) 290 (let ([sfd ($source-file-descriptor fn ip (eqv? fp 0))]) 291 (unless (eqv? fp 0) (set-port-position! ip fp)) 292 ; whack ip so on-reset close-port call above closes the text port 293 (set! ip (transcoded-port ip (current-transcoder))) 294 (ksrc ip sfd ($make-read ip sfd fp))))))))) 295 296 (set! $make-load-binary 297 (lambda (fn) 298 (make-load-binary '$make-load-binary fn 'load #f #f))) 299 300 (set-who! load-compiled-from-port 301 (lambda (ip) 302 (unless (and (input-port? ip) (binary-port? ip)) 303 ($oops who "~s is not a binary input port" ip)) 304 (do-load-binary who (port-name ip) ip 'load #f #f))) 305 306 (set-who! visit-compiled-from-port 307 (lambda (ip) 308 (unless (and (input-port? ip) (binary-port? ip)) 309 ($oops who "~s is not a binary input port" ip)) 310 (do-load-binary who (port-name ip) ip 'visit #f #f))) 311 312 (set-who! revisit-compiled-from-port 313 (lambda (ip) 314 (unless (and (input-port? ip) (binary-port? ip)) 315 ($oops who "~s is not a binary input port" ip)) 316 (do-load-binary who (port-name ip) ip 'revisit #f #f))) 317 318 (set-who! load-program 319 (rec load-program 320 (case-lambda 321 [(fn) (load-program fn eval)] 322 [(fn ev) 323 (unless (string? fn) ($oops who "~s is not a string" fn)) 324 (unless (procedure? ev) ($oops who "~s is not a procedure" ev)) 325 (with-source-path who fn 326 (lambda (fn) 327 (do-load who fn 'load #f #f 328 (lambda (ip sfd do-read) 329 ($set-port-flags! ip (constant port-flag-r6rs)) 330 (let loop ([x* '()]) 331 (let ([x (do-read)]) 332 (if (eof-object? x) 333 (begin 334 (close-port ip) 335 (ev `(top-level-program ,@(reverse x*))) 336 (void)) 337 (loop (cons x x*)))))))))]))) 338 339 (set-who! load-library ; like load, but sets #!r6rs mode 340 (rec load-library 341 (case-lambda 342 [(fn) (load-library fn eval)] 343 [(fn ev) 344 (unless (string? fn) ($oops who "~s is not a string" fn)) 345 (unless (procedure? ev) ($oops who "~s is not a procedure" ev)) 346 (with-source-path who fn 347 (lambda (fn) 348 (do-load who fn 'load #f #f 349 (lambda (ip sfd do-read) 350 ($set-port-flags! ip (constant port-flag-r6rs)) 351 (let loop () 352 (let ([x (do-read)]) 353 (unless (eof-object? x) 354 (ev x) 355 (loop)))) 356 (close-port ip)))))]))) 357 358 (set! $load-library ; for syntax.ss load-library 359 ; like load, but sets #!r6rs mode and does not use with-source-path, 360 ; since syntax.ss load-library has already determined the path. 361 ; adds fn's directory to source-directories 362 (lambda (fn situation importer) 363 (define who 'import) 364 (let ([fn (let ([host-fn (format "~a.~s" (path-root fn) (machine-type))]) 365 (if (file-exists? host-fn) host-fn fn))]) 366 (do-load who fn situation #t importer 367 (lambda (ip sfd do-read) 368 ($set-port-flags! ip (constant port-flag-r6rs)) 369 (parameterize ([source-directories (cons (path-parent fn) (source-directories))]) 370 (let loop () 371 (let ([x (do-read)]) 372 (unless (eof-object? x) 373 (eval x) 374 (loop))))) 375 (close-port ip)))))) 376 377 (set-who! load 378 (rec load 379 (case-lambda 380 [(fn) (load fn eval)] 381 [(fn ev) 382 (unless (string? fn) ($oops who "~s is not a string" fn)) 383 (unless (procedure? ev) ($oops who "~s is not a procedure" ev)) 384 (with-source-path who fn 385 (lambda (fn) 386 (do-load who fn 'load #f #f 387 (lambda (ip sfd do-read) 388 (let loop () 389 (let ([x (do-read)]) 390 (unless (eof-object? x) 391 (ev x) 392 (loop)))) 393 (close-port ip)))))]))) 394 395 (set! $visit 396 (lambda (who fn importer) 397 (do-load who fn 'visit #t importer #f))) 398 399 (set! $revisit 400 (lambda (who fn importer) 401 (do-load who fn 'revisit #t importer #f))) 402 403 (set-who! visit 404 (lambda (fn) 405 (do-load who fn 'visit #f #f #f))) 406 407 (set-who! revisit 408 (lambda (fn) 409 (do-load who fn 'revisit #f #f #f)))) 410 411(let () 412 (module sstats-record (make-sstats sstats? sstats-cpu sstats-real 413 sstats-bytes sstats-gc-count sstats-gc-cpu 414 sstats-gc-real sstats-gc-bytes 415 set-sstats-cpu! set-sstats-real! 416 set-sstats-bytes! set-sstats-gc-count! 417 set-sstats-gc-cpu! set-sstats-gc-real! 418 set-sstats-gc-bytes!) 419 (define-record-type (sstats make-sstats sstats?) 420 (nongenerative #{sstats pfwch3jd8ts96giujpitoverj-0}) 421 (sealed #t) 422 (fields 423 (mutable cpu sstats-cpu set-sstats-cpu!) 424 (mutable real sstats-real set-sstats-real!) 425 (mutable bytes sstats-bytes set-sstats-bytes!) 426 (mutable gc-count sstats-gc-count set-sstats-gc-count!) 427 (mutable gc-cpu sstats-gc-cpu set-sstats-gc-cpu!) 428 (mutable gc-real sstats-gc-real set-sstats-gc-real!) 429 (mutable gc-bytes sstats-gc-bytes set-sstats-gc-bytes!)) 430 (protocol 431 (lambda (new) 432 (lambda (cpu real bytes gc-count gc-cpu gc-real gc-bytes) 433 (new cpu real bytes gc-count gc-cpu gc-real gc-bytes)))))) 434 (define exact-integer? (lambda (x) (and (integer? x) (exact? x)))) 435 (set-who! make-sstats 436 (lambda (cpu real bytes gc-count gc-cpu gc-real gc-bytes) 437 (define verify-time 438 (lambda (name x) 439 (unless (time? x) 440 ($oops who "~s value ~s is not a time record" name x)))) 441 (define verify-exact-integer 442 (lambda (name x) 443 (unless (exact-integer? x) 444 ($oops who "~s value ~s is not an exact integer" name x)))) 445 (import sstats-record) 446 (verify-time 'cpu cpu) 447 (verify-time 'real real) 448 (verify-exact-integer 'bytes bytes) 449 (verify-exact-integer 'gc-count gc-count) 450 (verify-time 'gc-cpu gc-cpu) 451 (verify-time 'gc-real gc-real) 452 (verify-exact-integer 'gc-bytes gc-bytes) 453 (make-sstats cpu real bytes gc-count gc-cpu gc-real gc-bytes))) 454 (set! sstats? (lambda (x) (import sstats-record) (sstats? x))) 455 (let () 456 (define verify-sstats 457 (lambda (who x) 458 (import sstats-record) 459 (unless (sstats? x) ($oops who "~s is not an sstats record" x)))) 460 (define verify-exact-integer 461 (lambda (who x) 462 (unless (exact-integer? x) 463 ($oops who "~s is not an exact integer" x)))) 464 (define verify-time 465 (lambda (who x) 466 (unless (time? x) 467 ($oops who "~s is not a time record" x)))) 468 (define-syntax field 469 (lambda (x) 470 (syntax-case x () 471 [(_ name verify-arg) 472 (with-syntax ([sstats-name (construct-name #'sstats-record "sstats-" #'name)] 473 [set-sstats-name! (construct-name #'sstats-record "set-sstats-" #'name "!")]) 474 #'(begin 475 (set-who! sstats-name 476 (lambda (x) 477 (import sstats-record) 478 (verify-sstats who x) 479 (sstats-name x))) 480 (set-who! set-sstats-name! 481 (lambda (x n) 482 (import sstats-record) 483 (verify-sstats who x) 484 (verify-arg who n) 485 (set-sstats-name! x n)))))]))) 486 (field cpu verify-time) 487 (field real verify-time) 488 (field bytes verify-exact-integer) 489 (field gc-count verify-exact-integer) 490 (field gc-cpu verify-time) 491 (field gc-real verify-time) 492 (field gc-bytes verify-exact-integer))) 493 494(define-who sstats-print 495 (rec sstats-print 496 (case-lambda 497 [(s) (sstats-print s (current-output-port))] 498 [(s port) 499 (unless (sstats? s) 500 ($oops who "~s is not an sstats record" s)) 501 (unless (and (output-port? port) (textual-port? port)) 502 ($oops who "~s is not a textual output port" port)) 503 (let ([collections (sstats-gc-count s)] 504 [time->string 505 (lambda (x) 506 ;; based on record-writer for ts in date.ss 507 (let ([sec (time-second x)] [nsec (time-nanosecond x)]) 508 (if (and (< sec 0) (> nsec 0)) 509 (format "-~d.~9,'0ds" (- -1 sec) (- 1000000000 nsec)) 510 (format "~d.~9,'0ds" sec nsec))))]) 511 (if (zero? collections) 512 (fprintf port 513" no collections 514 ~a elapsed cpu time 515 ~a elapsed real time 516 ~s bytes allocated 517" 518 (time->string (sstats-cpu s)) 519 (time->string (sstats-real s)) 520 (sstats-bytes s)) 521 (fprintf port 522" ~s collection~:p 523 ~a elapsed cpu time, including ~a collecting 524 ~a elapsed real time, including ~a collecting 525 ~s bytes allocated, including ~s bytes reclaimed 526" 527 collections 528 (time->string (sstats-cpu s)) (time->string (sstats-gc-cpu s)) 529 (time->string (sstats-real s)) (time->string (sstats-gc-real s)) 530 (sstats-bytes s) (sstats-gc-bytes s))))]))) 531 532(define display-statistics 533 (case-lambda 534 [() (display-statistics (current-output-port))] 535 [(p) 536 (unless (and (output-port? p) (textual-port? p)) 537 ($oops 'display-statistics "~s is not a textual output port" p)) 538 (sstats-print (statistics) p)])) 539 540(define-who sstats-difference 541 (lambda (a b) 542 (unless (sstats? a) 543 ($oops who "~s is not an sstats record" a)) 544 (unless (sstats? b) 545 ($oops who "~s is not an sstats record" b)) 546 (let ([int-diff (lambda (f a b) (- (f a) (f b)))] 547 [time-diff (lambda (f a b) (time-difference (f a) (f b)))]) 548 (make-sstats 549 (time-diff sstats-cpu a b) 550 (time-diff sstats-real a b) 551 (int-diff sstats-bytes a b) 552 (int-diff sstats-gc-count a b) 553 (time-diff sstats-gc-cpu a b) 554 (time-diff sstats-gc-real a b) 555 (int-diff sstats-gc-bytes a b))))) 556 557(define collect-generation-radix 558 (make-parameter 559 4 560 (lambda (v) 561 (unless (and (fixnum? v) (fx< 0 v)) 562 ($oops 'collect-generation-radix "~s is not a positive fixnum" v)) 563 v))) 564 565(define $reset-protect 566 (lambda (body out) 567 ((call/cc 568 (lambda (k) 569 (parameterize ([reset-handler 570 (lambda () 571 (k (lambda () 572 (out) 573 ((reset-handler)))))]) 574 (with-exception-handler 575 (lambda (c) 576 ; would prefer not to burn bridges even for serious condition 577 ; if the exception is continuable, but we have no way to know 578 ; short of grubbing through the continuation 579 (if (serious-condition? c) 580 (k (lambda () (out) (raise c))) 581 (raise-continuable c))) 582 (lambda () 583 (call-with-values body 584 (case-lambda 585 [(v) (lambda () v)] 586 [v* (lambda () (apply values v*))])))))))))) 587 588(define exit-handler) 589(define reset-handler) 590(define abort-handler) 591(let ([c-exit (foreign-procedure "(cs)c_exit" (integer-32) void)]) 592 (define (integer-32? x) 593 (and (integer? x) 594 (exact? x) 595 (<= #x-80000000 x #x7fffffff))) 596 597 (set! exit-handler 598 ($make-thread-parameter 599 (case-lambda 600 [() (c-exit 0)] 601 [(x . args) (c-exit (if (eqv? x (void)) 0 (if (integer-32? x) x -1)))]) 602 (lambda (v) 603 (unless (procedure? v) 604 ($oops 'exit-handler "~s is not a procedure" v)) 605 v))) 606 607 (set! reset-handler 608 ($make-thread-parameter 609 (lambda () (c-exit 0)) 610 (lambda (v) 611 (unless (procedure? v) 612 ($oops 'reset-handler "~s is not a procedure" v)) 613 v))) 614 615 (set! abort-handler 616 ($make-thread-parameter 617 (case-lambda 618 [() (c-exit -1)] 619 [(x) (c-exit (if (eqv? x (void)) 0 (if (integer-32? x) x -1)))]) 620 (lambda (v) 621 (unless (procedure? v) 622 ($oops 'abort-handler "~s is not a procedure" v)) 623 v)))) 624 625(let () 626 (define (unexpected-return who) 627 ($oops who (format "unexpected return from ~s handler" who))) 628 629 (set-who! exit 630 (lambda args 631 (apply (exit-handler) args) 632 (unexpected-return who))) 633 634 (set-who! #(r6rs: exit) 635 (case-lambda 636 [() ((exit-handler)) (unexpected-return who)] 637 [(x) ((exit-handler) x) (unexpected-return who)])) 638 639 (set-who! reset 640 (lambda () 641 ((reset-handler)) 642 (unexpected-return who))) 643 644 (set-who! abort 645 (case-lambda 646 [() ((abort-handler)) (unexpected-return who)] 647 [(x) ((abort-handler) x) (unexpected-return who)]))) 648 649(define $interrupt ($make-thread-parameter void)) 650 651(define $format-scheme-version 652 (lambda (n) 653 (if (= (logand n 255) 0) 654 (format "~d.~d" 655 (ash n -16) 656 (logand (ash n -8) 255)) 657 (format "~d.~d.~d" 658 (ash n -16) 659 (logand (ash n -8) 255) 660 (logand n 255))))) 661 662; set in back.ss 663(define $scheme-version) 664 665(define scheme-version-number 666 (lambda () 667 (let ([n (constant scheme-version)]) 668 (values 669 (ash n -16) 670 (logand (ash n -8) 255) 671 (logand n 255))))) 672 673(define scheme-version 674 (let ([s #f]) 675 (lambda () 676 (unless s 677 (set! s 678 (format "~:[Petite ~;~]Chez Scheme Version ~a" 679 $compiler-is-loaded? 680 $scheme-version))) 681 s))) 682 683(define petite? 684 (lambda () 685 (not $compiler-is-loaded?))) 686 687(define threaded? 688 (lambda () 689 (if-feature pthreads #t #f))) 690 691(define get-process-id (foreign-procedure "(cs)getpid" () integer-32)) 692 693(set! get-thread-id 694 (lambda () 695 ($tc-field 'threadno ($tc)))) 696 697(define-who sleep 698 (let ([fp (foreign-procedure "(cs)nanosleep" (ptr ptr) void)]) 699 (lambda (t) 700 (unless (and (time? t) (eq? (time-type t) 'time-duration)) 701 ($oops who "~s is not a time record of type time-duration" t)) 702 (fp (time-second t) (time-nanosecond t))))) 703 704(define $scheme-greeting 705 (lambda () 706 (format "~a\nCopyright 1984-2020 Cisco Systems, Inc.\n" 707 (scheme-version)))) 708 709(define $session-key #f) 710(define $scheme-init) 711(define $scheme) 712(define $script) 713(define $as-time-goes-by) 714(define collect) 715(define break-handler) 716(define debug) 717 718(let () 719 720(define debug-condition* '()) 721 722(module (docollect collect-init) 723 (define gc-trip 0) 724 (define gc-cpu (make-time 'time-collector-cpu 0 0)) 725 (define gc-real (make-time 'time-collector-real 0 0)) 726 (define gc-bytes 0) 727 (define gc-count 0) 728 (define start-bytes 0) 729 (define docollect 730 (let ([do-gc (foreign-procedure "(cs)do_gc" (int int int) void)]) 731 (lambda (p) 732 (with-tc-mutex 733 (unless (= $active-threads 1) 734 ($oops 'collect "cannot collect when multiple threads are active")) 735 (let-values ([(trip g gmintarget gmaxtarget) (p gc-trip)]) 736 (set! gc-trip trip) 737 (let ([cpu (current-time 'time-thread)] [real (current-time 'time-monotonic)]) 738 (set! gc-bytes (+ gc-bytes (bytes-allocated))) 739 (when (collect-notify) 740 (fprintf (console-output-port) 741 "~%[collecting generation ~s into generation ~s..." 742 g gmaxtarget) 743 (flush-output-port (console-output-port))) 744 (when (eqv? g (collect-maximum-generation)) 745 ($clear-source-lines-cache)) 746 (do-gc g gmintarget gmaxtarget) 747 ($close-resurrected-files) 748 (when-feature pthreads 749 ($close-resurrected-mutexes&conditions)) 750 (when (collect-notify) 751 (fprintf (console-output-port) "done]~%") 752 (flush-output-port (console-output-port))) 753 (set! gc-bytes (- gc-bytes (bytes-allocated))) 754 (set! gc-cpu (add-duration gc-cpu (time-difference (current-time 'time-thread) cpu))) 755 (set! gc-real (add-duration gc-real (time-difference (current-time 'time-monotonic) real))) 756 (set! gc-count (1+ gc-count)))))))) 757 (define collect-init 758 (lambda () 759 (set! gc-trip 0) 760 (set! gc-cpu (make-time 'time-collector-cpu 0 0)) 761 (set! gc-real (make-time 'time-collector-real 0 0)) 762 (set! gc-count 0) 763 (set! gc-bytes 0) 764 (set! start-bytes (bytes-allocated)))) 765 (set! $gc-real-time (lambda () gc-real)) 766 (set! $gc-cpu-time (lambda () gc-cpu)) 767 (set! initial-bytes-allocated (lambda () start-bytes)) 768 (set! bytes-deallocated (lambda () gc-bytes)) 769 (set! collections (lambda () gc-count)) 770 (set! statistics 771 (lambda () 772 (make-sstats 773 (current-time 'time-thread) 774 (current-time 'time-monotonic) 775 (+ (- (bytes-allocated) start-bytes) gc-bytes) 776 gc-count 777 gc-cpu 778 gc-real 779 gc-bytes)))) 780 781(set-who! collect 782 (let () 783 (define collect0 784 (lambda () 785 (docollect 786 (lambda (gct) 787 (let ([gct (+ gct 1)]) 788 (let ([cmg (collect-maximum-generation)]) 789 (let loop ([g cmg]) 790 (if (= (modulo gct (expt (collect-generation-radix) g)) 0) 791 (if (fx= g cmg) 792 (values 0 g (fxmin g 1) g) 793 (values gct g 1 (fx+ g 1))) 794 (loop (fx- g 1)))))))))) 795 (define collect2 796 (lambda (g gmintarget gmaxtarget) 797 (docollect 798 (lambda (gct) 799 (values 800 ; make gc-trip to look like we've just collected generation g 801 ; w/o also having collected generation g+1 802 (if (fx= g (collect-maximum-generation)) 803 0 804 (let ([gct (+ gct 1)]) 805 (define (trip g) 806 (let ([n (expt (collect-generation-radix) g)]) 807 (+ gct (modulo (- n gct) n)))) 808 (let ([next (trip g)] [limit (trip (fx+ g 1))]) 809 (if (< next limit) next (- limit 1))))) 810 g gmintarget gmaxtarget))))) 811 (case-lambda 812 [() (collect0)] 813 [(g) 814 (let ([cmg (collect-maximum-generation)]) 815 (unless (and (fixnum? g) (fx<= 0 g cmg)) 816 ($oops who "invalid generation ~s" g)) 817 (let ([gtarget (if (fx= g cmg) g (fx+ g 1))]) 818 (collect2 g gtarget gtarget)))] 819 [(g gtarget) 820 (let ([cmg (collect-maximum-generation)]) 821 (unless (and (fixnum? g) (fx<= 0 g cmg)) 822 ($oops who "invalid generation ~s" g)) 823 (unless (if (fx= g cmg) 824 (or (eqv? gtarget g) (eq? gtarget 'static)) 825 (or (eqv? gtarget g) (eqv? gtarget (fx+ g 1)))) 826 ($oops who "invalid target generation ~s for generation ~s" gtarget g))) 827 (let ([gtarget (if (eq? gtarget 'static) (constant static-generation) gtarget)]) 828 (collect2 g gtarget gtarget))] 829 [(g gmintarget gmaxtarget) 830 (let ([cmg (collect-maximum-generation)]) 831 (unless (and (fixnum? g) (fx<= 0 g cmg)) 832 ($oops who "invalid generation ~s" g)) 833 (unless (if (fx= g cmg) 834 (or (eqv? gmaxtarget g) (eq? gmaxtarget 'static)) 835 (or (eqv? gmaxtarget g) (eqv? gmaxtarget (fx+ g 1)))) 836 ($oops who "invalid maximum target generation ~s for generation ~s" gmaxtarget g)) 837 (unless (or (eqv? gmintarget gmaxtarget) 838 (and (fixnum? gmintarget) 839 (fx<= 1 gmintarget (if (fixnum? gmaxtarget) gmaxtarget cmg)))) 840 ($oops who "invalid minimum target generation ~s for generation ~s and maximum target generation ~s" gmintarget g gmaxtarget))) 841 (collect2 g 842 (if (eq? gmintarget 'static) (constant static-generation) gmintarget) 843 (if (eq? gmaxtarget 'static) (constant static-generation) gmaxtarget))]))) 844 845(set! collect-rendezvous 846 (let ([fire-collector (foreign-procedure "(cs)fire_collector" () void)]) 847 (lambda () 848 (fire-collector) 849 ($collect-rendezvous)))) 850 851(set! keyboard-interrupt-handler 852 ($make-thread-parameter 853 (lambda () 854 (clear-output-port (console-output-port)) 855 (fresh-line (console-output-port)) 856 (flush-output-port (console-output-port)) 857 (($interrupt))) 858 (lambda (x) 859 (unless (procedure? x) 860 ($oops 'keyboard-interrupt-handler "~s is not a procedure" x)) 861 x))) 862 863(let () 864 (define register-scheme-signal 865 (foreign-procedure "(cs)register_scheme_signal" (iptr) void)) 866 867 (define signal-alist '()) 868 869 (set! register-signal-handler 870 (lambda (sig handler) 871 (unless (fixnum? sig) 872 ($oops 'register-signal-handler "~s is not a fixnum" sig)) 873 (unless (procedure? handler) 874 ($oops 'register-signal-handler "~s is not a procedure" handler)) 875 (critical-section 876 (register-scheme-signal sig) 877 (let ((a (assq sig signal-alist))) 878 (if a 879 (set-cdr! a handler) 880 (set! signal-alist (cons (cons sig handler) signal-alist))))))) 881 882 (set! $signal-interrupt-handler 883 (lambda (sig) 884 (let ((a (assq sig signal-alist))) 885 (unless a 886 ($oops '$signal-interrupt-handler 887 "unexpected signal number ~d received~%" 888 sig)) 889 ((cdr a) sig))))) 890 891;;; entry point from C kernel 892 893(set! $scheme-init 894 (lambda () 895 (set! debug-condition* '()) 896 (collect-init) 897 ($io-init) 898 (set! $session-key #f) 899 ($interrupt reset) 900 ($clear-pass-stats) 901 (enable-interrupts))) 902 903(set! $scheme 904 (lambda (fns) 905 (define (go) 906 (call/cc 907 (lambda (k) 908 (parameterize ([abort-handler 909 (case-lambda [() (k -1)] [(x) (k x)])] 910 [exit-handler 911 (case-lambda [() (k (void))] [(x . args) (k x)])] 912 [reset-handler (lambda () (k -1))]) 913 (apply (scheme-start) fns))))) 914 (unless (suppress-greeting) 915 (display ($scheme-greeting) (console-output-port)) 916 (newline (console-output-port)) 917 (flush-output-port (console-output-port))) 918 (if-feature expeditor 919 (if ($enable-expeditor) ($expeditor go) (go)) 920 (go)))) 921 922(set! $script 923 (lambda (program? fn fns) 924 (define (go) 925 (call/cc 926 (lambda (k) 927 (parameterize ([abort-handler 928 (case-lambda [() (k -1)] [(x) (k x)])] 929 [exit-handler 930 (case-lambda [() (k (void))] [(x . args) (k x)])] 931 [reset-handler (lambda () (k -1))]) 932 (apply (if program? (scheme-program) (scheme-script)) fn fns))))) 933 (if-feature expeditor 934 (if ($enable-expeditor) ($expeditor go) (go)) 935 (go)))) 936 937(set! $as-time-goes-by 938 (lambda (e t) 939 (define sanitize 940 (lambda (s) 941 (define sanitize-time 942 (lambda (t) 943 (if (< (time-second t) 0) 944 (make-time 'time-duration 0 0) 945 t))) 946 (define sanitize-count 947 (lambda (n) 948 (max n 0))) 949 (make-sstats 950 (sanitize-time (sstats-cpu s)) 951 (sanitize-time (sstats-real s)) 952 (sanitize-count (sstats-bytes s)) 953 (sanitize-count (sstats-gc-count s)) 954 (sanitize-time (sstats-gc-cpu s)) 955 (sanitize-time (sstats-gc-real s)) 956 (sanitize-count (sstats-gc-bytes s))))) 957 (define prstats 958 (lambda (b1 b2) 959 (let ([a (statistics)]) 960 (parameterize ([print-level 2] [print-length 2]) 961 (fprintf (console-output-port) "(time ~s)~%" e)) 962 (let ([elapsed (sstats-difference a b2)]) 963 (let ([overhead (sstats-difference b2 b1)]) 964 (let ([adjusted (sanitize (sstats-difference elapsed overhead))]) 965 (sstats-print adjusted (console-output-port))))) 966 (flush-output-port (console-output-port))))) 967 (let ([b1 (statistics)]) 968 (let ([b2 (statistics)]) 969 (call-with-values t 970 (case-lambda 971 [(v) (prstats b1 b2) v] 972 [(v1 v2) (prstats b1 b2) (values v1 v2)] 973 [(v1 v2 v3) (prstats b1 b2) (values v1 v2 v3)] 974 [(v1 v2 v3 v4) (prstats b1 b2) (values v1 v2 v3 v4)] 975 [r (prstats b1 b2) (apply values r)])))))) 976 977(set! $report-string 978 (lambda (dest what who msg args) 979 (let ([what (and (not (equal? what "")) what)] 980 [who (and (not (equal? who "")) who)]) 981 (parameterize ([print-level 3] [print-length 6]) 982 (format dest "~@[~@(~a~)~]~:[~; in ~]~@[~a~]~:[~;: ~]~@[~?~]" 983 what 984 (and what who) 985 who 986 (and (or what who) (not (equal? msg ""))) 987 msg 988 args))))) 989 990(let () 991(define report 992 (lambda (what who msg args) 993 (fresh-line (console-output-port)) 994 ($report-string (console-output-port) what who msg args) 995 (newline (console-output-port)) 996 (flush-output-port (console-output-port)))) 997 998(set! break-handler 999 ($make-thread-parameter 1000 (case-lambda 1001 [(who msg . args) 1002 (unless (string? msg) 1003 ($oops 'default-break-handler "~s is not a string" msg)) 1004 (report "break" who msg args) 1005 (($interrupt))] 1006 [(who) 1007 (report "break" who "" '()) 1008 (($interrupt))] 1009 [() 1010 (($interrupt))]) 1011 (lambda (x) 1012 (unless (procedure? x) 1013 ($oops 'break-handler "~s is not a procedure" x)) 1014 x))) 1015) 1016 1017(set-who! debug-condition 1018 (case-lambda 1019 [() (cond 1020 [(assv ($tc-field 'threadno ($tc)) debug-condition*) => cdr] 1021 [else #f])] 1022 [(c) 1023 (let ([n ($tc-field 'threadno ($tc))]) 1024 (with-tc-mutex 1025 (set! debug-condition* 1026 (let ([ls (remp (lambda (a) (eqv? (car a) n)) debug-condition*)]) 1027 (if c (cons (cons n c) ls) ls)))))])) 1028 1029(set! debug 1030 (lambda () 1031 (define line-limit 74) 1032 (define pad 1033 (lambda (s n p) 1034 (let ([i (string-length s)]) 1035 (when (> n i) (display (make-string (- n i) #\space) p)) 1036 (display s p) 1037 (max i n)))) 1038 (define numbered-line-display 1039 (lambda (point? n c p) 1040 (display (if point? "*" " ")) 1041 (let ([s (with-output-to-string (lambda () (display-condition c)))]) 1042 (let ([k (- line-limit (+ (pad (number->string n) 4 p) 2))]) 1043 (display ": " p) 1044 (let ([i (string-length s)]) 1045 (if (> i k) 1046 (fprintf p "~a ...~%" (substring s 0 (- k 4))) 1047 (fprintf p "~a~%" s))))))) 1048 (define unnumbered-line-display 1049 (lambda (c p) 1050 (let ([s (with-output-to-string (lambda () (display-condition c)))]) 1051 (let ([k (- line-limit 2)]) 1052 (display " " p) 1053 (let ([i (string-length s)]) 1054 (if (> i k) 1055 (fprintf p "~a ...~%" (substring s 0 (- k 4))) 1056 (fprintf p "~a~%" s))))))) 1057 (define printem 1058 (lambda (point ls p) 1059 (if (null? (cdr ls)) 1060 (let ([x (car ls)]) 1061 (unnumbered-line-display (cdr x) p)) 1062 (for-each 1063 (lambda (x) 1064 (numbered-line-display (eq? x point) (car x) (cdr x) p)) 1065 ls)))) 1066 (define debug-cafe 1067 (lambda (point ls) 1068 (parameterize ([$interrupt void]) 1069 (clear-input-port (console-input-port)) 1070 (let ([waiter (call/cc 1071 (lambda (k) 1072 (rec f (lambda () (k f)))))]) 1073 (fprintf (console-output-port) "debug> ") 1074 (flush-output-port (console-output-port)) 1075 (let ([x (let ([x (parameterize ([$interrupt waiter] 1076 [reset-handler waiter]) 1077 (read (console-input-port)))]) 1078 (if (eof-object? x) 1079 (begin 1080 (newline (console-output-port)) 1081 (flush-output-port (console-output-port)) 1082 'e) 1083 x))]) 1084 (case x 1085 [(i) 1086 (let ([c (cdr point)]) 1087 (if (continuation-condition? c) 1088 (inspect (condition-continuation c)) 1089 (display "the raise continuation is not available\n"))) 1090 (waiter)] 1091 [(c) 1092 (inspect (cdr point)) 1093 (waiter)] 1094 [(q) 1095 (with-tc-mutex 1096 (for-each 1097 (lambda (x) (set! debug-condition* (remq x debug-condition*))) 1098 ls)) 1099 (void)] 1100 [(e) 1101 (void)] 1102 [(s) 1103 (printem point 1104 (sort (lambda (x y) (< (car x) (car y))) ls) 1105 (console-output-port)) 1106 (waiter)] 1107 [(?) 1108 (if (null? (cdr ls)) 1109 (fprintf (console-output-port) 1110"Type i to inspect the raise continuation (if available) 1111 s to display the condition 1112 c to inspect the condition 1113 e or eof to exit the debugger, retaining error continuation 1114 q to exit the debugger, discarding error continuation 1115") 1116 (fprintf (console-output-port) 1117"Type i to inspect the selected thread's raise continuation (if available) 1118 <n> to select thread <n> 1119 s to display the conditions 1120 c to inspect the selected thread's condition 1121 e or eof to exit the debugger, retaining error continuations 1122 q to exit the debugger, discarding error continuations 1123")) 1124 (flush-output-port (console-output-port)) 1125 (waiter)] 1126 [else 1127 (cond 1128 [(assv x ls) => 1129 (lambda (a) 1130 (set! point a) 1131 (waiter))] 1132 [(and (integer? x) (nonnegative? x)) 1133 (fprintf (console-output-port) 1134 "No saved error continution for thread ~s.~%" 1135 x) 1136 (flush-output-port (console-output-port)) 1137 (waiter)] 1138 [else 1139 (fprintf (console-output-port) 1140 "Invalid command. Type ? for options.~%") 1141 (flush-output-port (console-output-port)) 1142 (waiter)])])))))) 1143 (let ([ls debug-condition*]) 1144 (cond 1145 [(null? ls) 1146 (fprintf (console-output-port) "Nothing to debug.~%") 1147 (flush-output-port (console-output-port))] 1148 [else 1149 (debug-cafe (car ls) ls)])))) 1150) 1151 1152(define $collect-rendezvous 1153 (lambda () 1154 (define once 1155 (let ([once #f]) 1156 (lambda () 1157 (when (eq? once #t) 1158 ($oops '$collect-rendezvous 1159 "cannot return to the collect-request-handler")) 1160 (set! once #t)))) 1161 (if-feature pthreads 1162 (with-tc-mutex 1163 (let f () 1164 (when $collect-request-pending 1165 (if (= $active-threads 1) ; last one standing 1166 (dynamic-wind 1167 once 1168 (collect-request-handler) 1169 (lambda () 1170 (set! $collect-request-pending #f) 1171 (condition-broadcast $collect-cond))) 1172 (begin 1173 (condition-wait $collect-cond $tc-mutex) 1174 (f)))))) 1175 (critical-section 1176 (dynamic-wind 1177 once 1178 (collect-request-handler) 1179 (lambda () (set! $collect-request-pending #f))))))) 1180 1181(define collect-request-handler 1182 (make-parameter 1183 (lambda () (collect)) 1184 (lambda (x) 1185 (unless (procedure? x) 1186 ($oops 'collect-request-handler "~s is not a procedure" x)) 1187 x))) 1188 1189(define collect-notify (make-parameter #f (lambda (x) (and x #t)))) 1190 1191(define $c-error 1192 (lambda (arg . error-args) 1193 ; error-args may be present along doargerr path, but we presently 1194 ; ignore them 1195 (define-syntax c-error-case 1196 (lambda (x) 1197 (syntax-case x () 1198 [(_ arg [(key) fmls e1 e2 ...] ...) 1199 (with-syntax ([(k ...) (map lookup-constant (datum (key ...)))]) 1200 #'(let ([t arg]) 1201 (record-case t 1202 [(k) fmls e1 e2 ...] 1203 ... 1204 [else ($oops '$c-error "invalid error type ~s" t)])))]))) 1205 (c-error-case arg 1206 [(ERROR_OTHER) args (apply $oops args)] 1207 [(ERROR_CALL_UNBOUND) (cnt symbol arg1?) 1208 ($oops #f "variable ~:s is not bound" symbol)] 1209 [(ERROR_CALL_NONPROCEDURE_SYMBOL) (cnt symbol arg1?) 1210 ($oops #f "attempt to apply non-procedure ~s" 1211 ($top-level-value symbol))] 1212 [(ERROR_CALL_NONPROCEDURE) (cnt nonprocedure arg1?) 1213 ($oops #f "attempt to apply non-procedure ~s" nonprocedure)] 1214 [(ERROR_CALL_ARGUMENT_COUNT) (cnt procedure arg1?) 1215 ($oops #f "incorrect number of arguments to ~s" procedure)] 1216 [(ERROR_RESET) (who msg . args) 1217 ($oops who "~?. Some debugging context lost" msg args)] 1218 [(ERROR_NONCONTINUABLE_INTERRUPT) args 1219 (let ([noncontinuable-interrupt 1220 (lambda () 1221 ((keyboard-interrupt-handler)) 1222 (fprintf (console-output-port) 1223 "Noncontinuable interrupt.~%") 1224 (reset))]) 1225 ;; ruse to get inspector to print "continuation in 1226 ;; noncontinuable-interrupt" instead of "#c-error". 1227 (noncontinuable-interrupt))] 1228 [(ERROR_VALUES) (cnt) 1229 ($oops #f 1230 "returned ~r values to single value return context" 1231 cnt)] 1232 [(ERROR_MVLET) (cnt) 1233 ($oops #f 1234 "incorrect number of values received in multiple value context")]))) 1235 1236(define break 1237 (lambda args 1238 (apply (break-handler) args))) 1239 1240(define timer-interrupt-handler 1241 ($make-thread-parameter 1242 (lambda () 1243 ($oops 'timer-interrupt 1244 "timer interrupt occurred with no handler defined")) 1245 (lambda (x) 1246 (unless (procedure? x) 1247 ($oops 'timer-interrupt-handler "~s is not a procedure" x)) 1248 x))) 1249 1250(define $symbol-type 1251 (lambda (name) 1252 (let ((flags ($sgetprop name '*flags* 0))) 1253 (cond 1254 [(any-set? (prim-mask system) flags) 'system] 1255 [(any-set? (prim-mask primitive) flags) 'primitive] 1256 [(any-set? (prim-mask keyword) flags) 1257 (if (any-set? (prim-mask library-uid) flags) 1258 'library-uid 1259 'keyword)] 1260 [(any-set? (prim-mask system-keyword) flags) 1261 (if (any-set? (prim-mask library-uid) flags) 1262 'system-library-uid 1263 'system-keyword)] 1264 [else 'unknown])))) 1265 1266(let () 1267 ; naive version is good enough for apropos 1268 (define (substring? s1 s2) 1269 (let ([n1 (string-length s1)] [n2 (string-length s2)]) 1270 (let loop2 ([i2 0]) 1271 (let loop1 ([i1 0] [j i2]) 1272 (if (fx= i1 n1) 1273 i2 1274 (and (not (fx= j n2)) 1275 (if (char=? (string-ref s1 i1) (string-ref s2 j)) 1276 (loop1 (fx+ i1 1) (fx+ j 1)) 1277 (loop2 (fx+ i2 1))))))))) 1278 (define sym<? (lambda (x y) (string-ci<? (symbol->string x) (symbol->string y)))) 1279 (define apropos-help 1280 (lambda (s env) 1281 (let ([s (if (symbol? s) (symbol->string s) s)]) 1282 (sort sym<? 1283 (let f ([ls (environment-symbols env)]) 1284 (if (null? ls) 1285 '() 1286 (if (substring? s (symbol->string (car ls))) 1287 (cons (car ls) (f (cdr ls))) 1288 (f (cdr ls))))))))) 1289 (define apropos-library-help 1290 (lambda (s) 1291 (define lib<? 1292 (lambda (lib1 lib2) 1293 (and (not (null? lib2)) 1294 (or (null? lib1) 1295 (if (eq? (car lib1) (car lib2)) 1296 (lib<? (cdr lib1) (cdr lib2)) 1297 (sym<? (car lib1) (car lib2))))))) 1298 (let ([s (if (symbol? s) (symbol->string s) s)]) 1299 (sort (lambda (ls1 ls2) (lib<? (car ls1) (car ls2))) 1300 (let do-libs ([lib* (library-list)] [match** '()]) 1301 (if (null? lib*) 1302 match** 1303 (do-libs (cdr lib*) 1304 (let do-exports ([x* (library-exports (car lib*))] [match* '()]) 1305 (if (null? x*) 1306 (if (null? match*) 1307 match** 1308 (cons (cons (car lib*) (sort sym<? match*)) match**)) 1309 (do-exports (cdr x*) 1310 (if (substring? s (symbol->string (car x*))) 1311 (cons (car x*) match*) 1312 match*))))))))))) 1313 (define check-s 1314 (lambda (who s) 1315 (unless (or (symbol? s) (string? s)) 1316 ($oops who "~s is not a symbol or string" s)))) 1317 (define check-env 1318 (lambda (who env) 1319 (unless (environment? env) 1320 ($oops 'apropos-list "~s is not an environment" env)))) 1321 (set! apropos-list 1322 (case-lambda 1323 [(s) 1324 (check-s 'apropos-list s) 1325 (append 1326 (apropos-help s (interaction-environment)) 1327 (apropos-library-help s))] 1328 [(s env) 1329 (check-s 'apropos-list s) 1330 (check-env 'apropos-list env) 1331 (append 1332 (apropos-help s env) 1333 (apropos-library-help s))])) 1334 (let () 1335 (define do-apropos 1336 (lambda (who where s env) 1337 (printf "~a environment:\n ~{~<~%~& ~1:; ~s~>~^,~}~&" where (apropos-help s env)) 1338 (for-each 1339 (lambda (x) (printf "~s:\n ~{~<~%~& ~1:; ~s~>~^,~}~&" (car x) (cdr x))) 1340 (apropos-library-help s)))) 1341 (set-who! apropos 1342 (case-lambda 1343 [(s) 1344 (check-s who s) 1345 (do-apropos who "interaction" s (interaction-environment))] 1346 [(s env) 1347 (check-s who s) 1348 (check-env who env) 1349 (do-apropos who "supplied" s env)])))) 1350 1351(let () 1352 (define-record-type pass-stats 1353 (nongenerative) 1354 (sealed #t) 1355 (fields 1356 (mutable calls) 1357 (mutable cpu) 1358 (mutable gc-cpu) 1359 (mutable bytes)) 1360 (protocol 1361 (lambda (n) 1362 (lambda () 1363 (let ([t (make-time 'time-duration 0 0)]) 1364 (n 0 t t 0)))))) 1365 1366 (define field-names '(name calls cpu gc-cpu bytes)) 1367 1368 (define stats-ht) 1369 1370 (define-threaded outer-ps #f) 1371 1372 (set! $clear-pass-stats 1373 (lambda () 1374 (set! stats-ht (make-eq-hashtable)))) 1375 1376 (set! $enable-pass-timing (make-parameter #f)) 1377 1378 (set-who! $pass-time 1379 (lambda (name thunk) 1380 (unless (symbol? name) ($oops who "~s is not a symbol" name)) 1381 (unless (procedure? thunk) ($oops who "~s is not a procedure" thunk)) 1382 (if ($enable-pass-timing) 1383 (let ([ps (with-tc-mutex 1384 (let ([a (hashtable-cell stats-ht name #f)]) 1385 (let ([ps (or (cdr a) (let ([ps (make-pass-stats)]) (set-cdr! a ps) ps))]) 1386 (pass-stats-calls-set! ps (+ (pass-stats-calls ps) 1)) 1387 ps)))]) 1388 (dynamic-wind 1389 (lambda () 1390 (with-tc-mutex 1391 (let ([cpu (current-time 'time-thread)] 1392 [gc-cpu (current-time 'time-collector-cpu)] 1393 [bytes (+ (bytes-deallocated) (bytes-allocated))]) 1394 (set-time-type! cpu 'time-duration) 1395 (set-time-type! gc-cpu 'time-duration) 1396 (when outer-ps 1397 (pass-stats-cpu-set! outer-ps (add-duration (pass-stats-cpu outer-ps) cpu)) 1398 (pass-stats-gc-cpu-set! outer-ps (add-duration (pass-stats-gc-cpu outer-ps) gc-cpu)) 1399 (pass-stats-bytes-set! outer-ps (+ (pass-stats-bytes outer-ps) bytes))) 1400 (pass-stats-cpu-set! ps (subtract-duration (pass-stats-cpu ps) cpu)) 1401 (pass-stats-gc-cpu-set! ps (subtract-duration (pass-stats-gc-cpu ps) gc-cpu)) 1402 (pass-stats-bytes-set! ps (- (pass-stats-bytes ps) bytes))))) 1403 (lambda () (fluid-let ([outer-ps ps]) (thunk))) 1404 (lambda () 1405 (with-tc-mutex 1406 (let ([cpu (current-time 'time-thread)] 1407 [gc-cpu (current-time 'time-collector-cpu)] 1408 [bytes (+ (bytes-deallocated) (bytes-allocated))]) 1409 (set-time-type! cpu 'time-duration) 1410 (set-time-type! gc-cpu 'time-duration) 1411 (when outer-ps 1412 (pass-stats-cpu-set! outer-ps (subtract-duration (pass-stats-cpu outer-ps) cpu)) 1413 (pass-stats-gc-cpu-set! outer-ps (subtract-duration (pass-stats-gc-cpu outer-ps) gc-cpu)) 1414 (pass-stats-bytes-set! outer-ps (- (pass-stats-bytes outer-ps) bytes))) 1415 (pass-stats-cpu-set! ps (add-duration (pass-stats-cpu ps) cpu)) 1416 (pass-stats-gc-cpu-set! ps (add-duration (pass-stats-gc-cpu ps) gc-cpu)) 1417 (pass-stats-bytes-set! ps (+ (pass-stats-bytes ps) bytes))))))) 1418 (thunk)))) 1419 1420 (set-who! $pass-stats-fields (lambda () field-names)) 1421 1422 (set! $pass-stats 1423 (lambda () 1424 (define (build-result namev psv) 1425 (vector->list 1426 (vector-map 1427 (lambda (name ps) 1428 (list name 1429 (pass-stats-calls ps) 1430 (pass-stats-cpu ps) 1431 (pass-stats-gc-cpu ps) 1432 (pass-stats-bytes ps))) 1433 namev 1434 psv))) 1435 (with-tc-mutex 1436 (if outer-ps 1437 (let ([cpu (current-time 'time-thread)] 1438 [gc-cpu (current-time 'time-collector-cpu)] 1439 [bytes (+ (bytes-deallocated) (bytes-allocated))]) 1440 (set-time-type! cpu 'time-duration) 1441 (set-time-type! gc-cpu 'time-duration) 1442 (pass-stats-cpu-set! outer-ps (add-duration (pass-stats-cpu outer-ps) cpu)) 1443 (pass-stats-gc-cpu-set! outer-ps (add-duration (pass-stats-gc-cpu outer-ps) gc-cpu)) 1444 (pass-stats-bytes-set! outer-ps (+ (pass-stats-bytes outer-ps) bytes)) 1445 (let ([result (call-with-values (lambda () (hashtable-entries stats-ht)) build-result)]) 1446 (pass-stats-cpu-set! outer-ps (subtract-duration (pass-stats-cpu outer-ps) cpu)) 1447 (pass-stats-gc-cpu-set! outer-ps (subtract-duration (pass-stats-gc-cpu outer-ps) gc-cpu)) 1448 (pass-stats-bytes-set! outer-ps (- (pass-stats-bytes outer-ps) bytes)) 1449 result)) 1450 (call-with-values (lambda () (hashtable-entries stats-ht)) build-result))))) 1451 1452 (let () 1453 (define who '$print-pass-stats) 1454 (define field-name-strings (map symbol->string field-names)) 1455 (define check-psls 1456 (lambda (psl*) 1457 (unless (list? psl*) ($oops who "~s is not a list" psl*)) 1458 (for-each 1459 (lambda (psl) 1460 (define exact-integer? (lambda (x) (or (fixnum? x) (bignum? x)))) 1461 (unless (and (fx= ($list-length psl who) 5) 1462 (apply (lambda (name calls cpu gc-cpu bytes) 1463 (and (exact-integer? calls) 1464 (time? cpu) 1465 (time? gc-cpu) 1466 (exact-integer? bytes))) 1467 psl)) 1468 ($oops who "malformed pass-stats entry ~s" psl))) 1469 psl*))) 1470 (define val->string 1471 (lambda (x) 1472 (cond 1473 [(time? x) 1474 (let-values ([(sec nsec) 1475 (let ([sec (time-second x)] [nsec (time-nanosecond x)]) 1476 (if (and (< sec 0) (> nsec 0)) 1477 (values (+ sec 1) (- 1000000000 nsec)) 1478 (values sec nsec)))]) 1479 (format "~d.~9,'0d" sec nsec))] 1480 [else (format "~s" x)]))) 1481 (define (print-pass-stats key psl*) 1482 (define psl<? 1483 (lambda (x y) 1484 (apply (lambda (x-name x-calls x-cpu x-gc-cpu x-bytes) 1485 (apply (lambda (y-name y-calls y-cpu y-gc-cpu y-bytes) 1486 (case (or key 'non-gc-cpu) 1487 [(non-gc-cpu) 1488 (time<? 1489 (time-difference x-cpu x-gc-cpu) 1490 (time-difference y-cpu y-gc-cpu))] 1491 [(cpu) (time<? x-cpu y-cpu)] 1492 [(gc-cpu) (time<? x-gc-cpu y-gc-cpu)] 1493 [(bytes) (< x-bytes y-bytes)] 1494 [(name) (string<? (symbol->string x-name) (symbol->string y-name))] 1495 [(calls) (< x-calls y-calls)] 1496 [else ($oops who "unrecognized sort key ~s" key)])) 1497 y)) 1498 x))) 1499 ; run check when passed psl* to check psl*; run when passed 1500 ; the value of ($pass-stats) to check our assumptions 1501 (check-psls psl*) 1502 (let ([psl* (append (sort psl<? psl*) 1503 (list (let loop ([psl* psl*] [calls 0] [cpu (make-time 'time-duration 0 0)] [gc-cpu (make-time 'time-duration 0 0)] [bytes 0]) 1504 (if (null? psl*) 1505 (list 'TOTAL calls cpu gc-cpu bytes) 1506 (apply (lambda (*name *calls *cpu *gc-cpu *bytes) 1507 (loop (cdr psl*) 1508 (+ calls *calls) 1509 (add-duration cpu *cpu) 1510 (add-duration gc-cpu *gc-cpu) 1511 (+ bytes *bytes))) 1512 (car psl*))))))]) 1513 (let ([s** (map (lambda (psl) (map val->string psl)) psl*)]) 1514 (let ([w* (fold-left (lambda (w* s*) 1515 (map (lambda (s w) (fxmax (string-length s) w)) s* w*)) 1516 (map string-length field-name-strings) 1517 s**)]) 1518 (define print-row 1519 (lambda (s*) 1520 (printf "~v<~a~;~> " (car w*) (car s*)) 1521 (for-each (lambda (s w) (printf "~v:<~a~> " w s)) (cdr s*) (cdr w*)) 1522 (newline))) 1523 (print-row field-name-strings) 1524 (print-row (map (lambda (w) (make-string w #\-)) w*)) 1525 (for-each print-row s**))))) 1526 (set! $print-pass-stats 1527 (case-lambda 1528 [() (print-pass-stats #f ($pass-stats))] 1529 [(key) (print-pass-stats key ($pass-stats))] 1530 [(key psl*) (print-pass-stats key psl*)])))) 1531) 1532