b2cecd2c0f
- updated version to 9.5.2
bintar/Makefile rpm/Makefile pkg/Makefile BUILDING NOTICE
makefiles/Mf-install.in makefiles/Makefile-csug.in scheme.1.in
c/Makefile.a6nt c/Makefile.i3nt c/Makefile.ta6nt c/Makefile.ti3nt
mats/Mf-a6nt mats/Mf-i3nt mats/Mf-ta6nt mats/Mf-ti3nt workarea
c/scheme.rc s/7.ss s/cmacros.ss release_notes/release_notes.stex
csug/copyright.stex csug/csug.stex rpm/Makefile pkg/Makefile
wininstall/Makefile wininstall/a6nt.wxs wininstall/i3nt.wxs
wininstall/ta6nt.wxs wininstall/ti3nt.wxs
- fixed handling of bintar, rpm, pkg make files
newrelease
- fixed a bug in the fasl representation and reading of mutually
recursive ftypes where one of the members of the cycle is the
parent of another, which manifested in the fasl reader raising
bogus "incompatible record type" exceptions. (The bug could also
affect other record-type descriptors with cycles involving parent
rtds and "extra" fields.) object files created before this fix
are incompatible with builds with this fix, and objects files
created after this fix are incompatible builds without this fix.
fasl.ss, strip.ss,
fasl.c,
ftype.ms,
release_notes.stex
original commit: 766d591c18c2779866d1a059700e6ff1c02cb3c5
1466 lines
54 KiB
Scheme
1466 lines
54 KiB
Scheme
"7.ss"
|
|
;;; 7.ss
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
;;; system operations
|
|
|
|
(define scheme-start
|
|
(make-parameter
|
|
(lambda fns (for-each load fns) (new-cafe))
|
|
(lambda (p)
|
|
(unless (procedure? p)
|
|
($oops 'scheme-start "~s is not a procedure" p))
|
|
p)))
|
|
|
|
(define scheme-script
|
|
(make-parameter
|
|
(lambda (fn . fns)
|
|
(command-line (cons fn fns))
|
|
(command-line-arguments fns)
|
|
(load fn))
|
|
(lambda (p)
|
|
(unless (procedure? p)
|
|
($oops 'scheme-script "~s is not a procedure" p))
|
|
p)))
|
|
|
|
(define scheme-program
|
|
(make-parameter
|
|
(lambda (fn . fns)
|
|
(command-line (cons fn fns))
|
|
(command-line-arguments fns)
|
|
(load-program fn))
|
|
(lambda (p)
|
|
(unless (procedure? p)
|
|
($oops 'scheme-program "~s is not a procedure" p))
|
|
p)))
|
|
|
|
(define command-line-arguments
|
|
(make-parameter
|
|
'()
|
|
(lambda (x)
|
|
(unless (and (list? x) (andmap string? x))
|
|
($oops 'command-line-arguments "~s is not a list of strings" x))
|
|
x)))
|
|
|
|
(define command-line
|
|
(make-parameter
|
|
'("")
|
|
(lambda (x)
|
|
(unless (and (list? x) (not (null? x)) (andmap string? x))
|
|
($oops 'command-line "~s is not a nonempty list of strings" x))
|
|
x)))
|
|
|
|
(define-who #(r6rs: command-line)
|
|
(lambda ()
|
|
(#2%command-line)))
|
|
|
|
(define-who bytes-allocated
|
|
(let ([ba (foreign-procedure "(cs)bytes_allocated"
|
|
(scheme-object scheme-object)
|
|
scheme-object)])
|
|
(define filter-generation
|
|
(lambda (g)
|
|
(cond
|
|
[(and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) g]
|
|
[(eq? g 'static) (constant static-generation)]
|
|
[else ($oops who "invalid generation ~s" g)])))
|
|
(define filter-space
|
|
(lambda (s)
|
|
(cond
|
|
[(assq s (constant real-space-alist)) => cdr]
|
|
[else ($oops who "invalid space ~s" s)])))
|
|
(case-lambda
|
|
[() (ba -1 -1)]
|
|
[(g) (ba (filter-generation g) -1)]
|
|
[(g s) (ba (if g (filter-generation g) -1) (if s (filter-space s) -1))])))
|
|
|
|
(define $spaces (lambda () (map car (constant real-space-alist))))
|
|
|
|
(define current-memory-bytes (foreign-procedure "(cs)curmembytes" () uptr))
|
|
(define maximum-memory-bytes (foreign-procedure "(cs)maxmembytes" () uptr))
|
|
|
|
(define reset-maximum-memory-bytes! (foreign-procedure "(cs)resetmaxmembytes" () void))
|
|
|
|
(define-who with-source-path
|
|
(lambda (whoarg fn p)
|
|
(unless (or (eq? whoarg #f) (string? whoarg) (symbol? whoarg)) ($oops who "invalid who argument ~s" whoarg))
|
|
(unless (procedure? p) ($oops who "~s is not a procedure" p))
|
|
(unless (string? fn) ($oops whoarg "~s is not a string" fn))
|
|
(let ([dirs (source-directories)])
|
|
(if (or (equal? dirs '("")) (equal? dirs '(".")) ($fixed-path? fn))
|
|
(p fn)
|
|
(let loop ([ls dirs])
|
|
(if (null? ls)
|
|
($oops whoarg "file ~s not found in source directories" fn)
|
|
(let ([path (let ([dir (car ls)])
|
|
(if (or (string=? dir "") (string=? dir "."))
|
|
fn
|
|
(format
|
|
(if (directory-separator?
|
|
(string-ref dir
|
|
(fx- (string-length dir) 1)))
|
|
"~a~a"
|
|
"~a/~a")
|
|
dir fn)))])
|
|
(if (guard (c [#t #f]) (close-input-port (open-input-file path)) #t)
|
|
(p path)
|
|
(loop (cdr ls))))))))))
|
|
|
|
(set! fasl-read
|
|
(let ()
|
|
(define $fasl-read (foreign-procedure "(cs)fasl_read" (ptr boolean ptr) ptr))
|
|
(define $bv-fasl-read (foreign-procedure "(cs)bv_fasl_read" (ptr ptr) ptr))
|
|
(define (get-uptr p)
|
|
(let ([k (get-u8 p)])
|
|
(let f ([k k] [n (fxsrl k 1)])
|
|
(if (fxlogbit? 0 k)
|
|
(let ([k (get-u8 p)])
|
|
(f k (logor (ash n 7) (fxsrl k 1))))
|
|
n))))
|
|
(define (malformed p) ($oops 'fasl-read "malformed fasl-object header found in ~s" p))
|
|
(define (check-header p)
|
|
(let ([bv (make-bytevector 8 (constant fasl-type-header))])
|
|
(unless (and (eqv? (get-bytevector-n! p bv 1 7) 7)
|
|
(bytevector=? bv (constant fasl-header)))
|
|
(malformed p)))
|
|
(let ([n (get-uptr p)])
|
|
(unless (= n (constant scheme-version))
|
|
($oops 'fasl-read "incompatible fasl-object version ~a found in ~s"
|
|
($format-scheme-version n) p)))
|
|
(let ([n (get-uptr p)])
|
|
(unless (or (= n (constant machine-type-any)) (= n (constant machine-type)))
|
|
(cond
|
|
[(assv n (constant machine-type-alist)) =>
|
|
(lambda (a)
|
|
($oops 'fasl-read "incompatible fasl-object machine-type ~s found in ~s"
|
|
(cdr a) p))]
|
|
[else (malformed p)])))
|
|
(unless (and (eqv? (get-u8 p) (char->integer #\()) ;)
|
|
(let f ()
|
|
(let ([n (get-u8 p)])
|
|
(and (not (eof-object? n)) ;(
|
|
(or (eqv? n (char->integer #\))) (f))))))
|
|
(malformed p)))
|
|
(lambda (p)
|
|
(unless (and (input-port? p) (binary-port? p))
|
|
($oops 'fasl-read "~s is not a binary input port" p))
|
|
(if (and ($port-flags-set? p (constant port-flag-file))
|
|
(eqv? (binary-port-input-count p) 0))
|
|
($fasl-read ($port-info p)
|
|
($port-flags-set? p (constant port-flag-compressed))
|
|
(port-name p))
|
|
(let fasl-entry ()
|
|
(let ([ty (get-u8 p)])
|
|
(cond
|
|
[(eof-object? ty) ty]
|
|
[(eqv? ty (constant fasl-type-header))
|
|
(check-header p)
|
|
(fasl-entry)]
|
|
[(eqv? ty (constant fasl-type-fasl-size))
|
|
($bv-fasl-read (get-bytevector-n p (get-uptr p)) (port-name p))]
|
|
[else (malformed p)])))))))
|
|
|
|
(define ($compiled-file-header? ip)
|
|
(let ([pos (port-position ip)])
|
|
(let ([cfh? (let* ([bv (constant fasl-header)] [n (bytevector-length bv)])
|
|
(let f ([i 0])
|
|
(or (fx= i n)
|
|
(and (eqv? (get-u8 ip) (bytevector-u8-ref bv i))
|
|
(f (fx+ i 1))))))])
|
|
(set-port-position! ip pos)
|
|
cfh?)))
|
|
|
|
(let ()
|
|
(define do-load-binary
|
|
(lambda (who fn ip situation for-import? results?)
|
|
(let ([load-binary (make-load-binary who fn situation for-import?)])
|
|
(let loop ([lookahead-x #f])
|
|
(let* ([x (or lookahead-x (fasl-read ip))]
|
|
[next-x (and results? (not (eof-object? x)) (fasl-read ip))])
|
|
(cond
|
|
[(eof-object? x) (close-port ip)]
|
|
[(and results? (eof-object? next-x)) (load-binary x)]
|
|
[else (load-binary x) (loop next-x)]))))))
|
|
|
|
(define (make-load-binary who fn situation for-import?)
|
|
(module (Lexpand? visit-stuff? visit-stuff-inner revisit-stuff? revisit-stuff-inner
|
|
recompile-info? library/ct-info? library/rt-info? program-info?)
|
|
(import (nanopass))
|
|
(include "base-lang.ss")
|
|
(include "expand-lang.ss"))
|
|
(define unexpected-value!
|
|
(lambda (x)
|
|
($oops who "unexpected value ~s read from ~a" x fn)))
|
|
(define run-inner
|
|
(lambda (x)
|
|
(cond
|
|
[(procedure? x) (x)]
|
|
[(library/rt-info? x) ($install-library/rt-desc x for-import? fn)]
|
|
[(library/ct-info? x) ($install-library/ct-desc x for-import? fn)]
|
|
[(program-info? x) ($install-program-desc x)]
|
|
[else (unexpected-value! x)])))
|
|
(define run-outer
|
|
(lambda (x)
|
|
(cond
|
|
[(recompile-info? x) (void)]
|
|
[(revisit-stuff? x) (when (memq situation '(load revisit)) (run-inner (revisit-stuff-inner x)))]
|
|
[(visit-stuff? x) (when (memq situation '(load visit)) (run-inner (visit-stuff-inner x)))]
|
|
[else (run-inner x)])))
|
|
(define run-vector
|
|
(lambda (v)
|
|
(let ([n (vector-length v)])
|
|
(unless (fx= n 0)
|
|
(let loop ([i 0])
|
|
(let ([x (vector-ref v i)] [i (fx+ i 1)])
|
|
(if (fx= i n)
|
|
(run-outer x) ; return value(s) of last form for load-compiled-from-port
|
|
(begin (run-outer x) (loop i)))))))))
|
|
(lambda (x)
|
|
(cond
|
|
[(vector? x) (run-vector x)]
|
|
[(Lexpand? x) ($interpret-backend x situation for-import? fn)]
|
|
[else (run-outer x)])))
|
|
|
|
(define (do-load who fn situation for-import? ksrc)
|
|
(let ([ip ($open-file-input-port who fn)])
|
|
(on-reset (close-port ip)
|
|
(let ([fp (let ([start-pos (port-position ip)])
|
|
(if (and (eqv? (get-u8 ip) (char->integer #\#))
|
|
(eqv? (get-u8 ip) (char->integer #\!))
|
|
(let ([b (get-u8 ip)]) (or (eqv? b (char->integer #\space)) (eqv? b (char->integer #\/)))))
|
|
(let loop ([fp 3])
|
|
(let ([b (get-u8 ip)])
|
|
(if (eof-object? b)
|
|
fp
|
|
(let ([fp (+ fp 1)])
|
|
(if (eqv? b (char->integer #\newline))
|
|
fp
|
|
(loop fp))))))
|
|
(begin (set-port-position! ip start-pos) 0)))])
|
|
(port-file-compressed! ip)
|
|
(if ($compiled-file-header? ip)
|
|
(do-load-binary who fn ip situation for-import? #f)
|
|
(begin
|
|
(when ($port-flags-set? ip (constant port-flag-compressed))
|
|
($oops who "missing header for compiled file ~s" fn))
|
|
(unless ksrc ($oops who "~a is not a compiled file" fn))
|
|
(unless (eqv? fp 0) (set-port-position! ip 0))
|
|
(let ([sfd ($source-file-descriptor fn ip (eqv? fp 0))])
|
|
(unless (eqv? fp 0) (set-port-position! ip fp))
|
|
; whack ip so on-reset close-port call above closes the text port
|
|
(set! ip (transcoded-port ip (current-transcoder)))
|
|
(ksrc ip sfd ($make-read ip sfd fp)))))))))
|
|
|
|
(set! $make-load-binary
|
|
(lambda (fn situation for-import?)
|
|
(make-load-binary '$make-load-binary fn situation for-import?)))
|
|
|
|
(set-who! load-compiled-from-port
|
|
(lambda (ip)
|
|
(unless (and (input-port? ip) (binary-port? ip))
|
|
($oops who "~s is not a binary input port" ip))
|
|
(do-load-binary who (port-name ip) ip 'load #f #t)))
|
|
|
|
(set-who! load-program
|
|
(rec load-program
|
|
(case-lambda
|
|
[(fn) (load-program fn eval)]
|
|
[(fn ev)
|
|
(unless (procedure? ev) ($oops who "~s is not a procedure" ev))
|
|
(with-source-path who fn
|
|
(lambda (fn)
|
|
(do-load who fn 'load #f
|
|
(lambda (ip sfd do-read)
|
|
($set-port-flags! ip (constant port-flag-r6rs))
|
|
(let loop ([x* '()])
|
|
(let ([x (do-read)])
|
|
(if (eof-object? x)
|
|
(begin
|
|
(close-port ip)
|
|
(ev `(top-level-program ,@(reverse x*)))
|
|
(void))
|
|
(loop (cons x x*)))))))))])))
|
|
|
|
(set-who! load-library ; like load, but sets #!r6rs mode
|
|
(rec load-library
|
|
(case-lambda
|
|
[(fn) (load-library fn eval)]
|
|
[(fn ev)
|
|
(unless (procedure? ev) ($oops who "~s is not a procedure" ev))
|
|
(with-source-path who fn
|
|
(lambda (fn)
|
|
(do-load who fn 'load #f
|
|
(lambda (ip sfd do-read)
|
|
($set-port-flags! ip (constant port-flag-r6rs))
|
|
(let loop ()
|
|
(let ([x (do-read)])
|
|
(unless (eof-object? x)
|
|
(ev x)
|
|
(loop))))
|
|
(close-port ip)))))])))
|
|
|
|
(set! $load-library ; for syntax.ss load-library
|
|
; like load, but sets #!r6rs mode and does not use with-source-path,
|
|
; since syntax.ss load-library has already determined the path.
|
|
; adds fn's directory to source-directories
|
|
(lambda (fn situation)
|
|
(define who 'import)
|
|
(let ([fn (let ([host-fn (format "~a.~s" (path-root fn) (machine-type))])
|
|
(if (file-exists? host-fn) host-fn fn))])
|
|
(do-load who fn situation #t
|
|
(lambda (ip sfd do-read)
|
|
($set-port-flags! ip (constant port-flag-r6rs))
|
|
(parameterize ([source-directories (cons (path-parent fn) (source-directories))])
|
|
(let loop ()
|
|
(let ([x (do-read)])
|
|
(unless (eof-object? x)
|
|
(eval x)
|
|
(loop)))))
|
|
(close-port ip))))))
|
|
|
|
(set-who! load
|
|
(rec load
|
|
(case-lambda
|
|
[(fn) (load fn eval)]
|
|
[(fn ev)
|
|
(unless (procedure? ev) ($oops who "~s is not a procedure" ev))
|
|
(with-source-path who fn
|
|
(lambda (fn)
|
|
(do-load who fn 'load #f
|
|
(lambda (ip sfd do-read)
|
|
(let loop ()
|
|
(let ([x (do-read)])
|
|
(unless (eof-object? x)
|
|
(ev x)
|
|
(loop))))
|
|
(close-port ip)))))])))
|
|
|
|
(set! $visit
|
|
(lambda (who fn)
|
|
(do-load who fn 'visit #t #f)))
|
|
|
|
(set! $revisit
|
|
(lambda (who fn)
|
|
(do-load who fn 'revisit #t #f)))
|
|
|
|
(set-who! visit
|
|
(lambda (fn)
|
|
(do-load who fn 'visit #f #f)))
|
|
|
|
(set-who! revisit
|
|
(lambda (fn)
|
|
(do-load who fn 'revisit #f #f))))
|
|
|
|
(let ()
|
|
(module sstats-record (make-sstats sstats? sstats-cpu sstats-real
|
|
sstats-bytes sstats-gc-count sstats-gc-cpu
|
|
sstats-gc-real sstats-gc-bytes
|
|
set-sstats-cpu! set-sstats-real!
|
|
set-sstats-bytes! set-sstats-gc-count!
|
|
set-sstats-gc-cpu! set-sstats-gc-real!
|
|
set-sstats-gc-bytes!)
|
|
(define-record-type (sstats make-sstats sstats?)
|
|
(nongenerative #{sstats pfwch3jd8ts96giujpitoverj-0})
|
|
(sealed #t)
|
|
(fields
|
|
(mutable cpu sstats-cpu set-sstats-cpu!)
|
|
(mutable real sstats-real set-sstats-real!)
|
|
(mutable bytes sstats-bytes set-sstats-bytes!)
|
|
(mutable gc-count sstats-gc-count set-sstats-gc-count!)
|
|
(mutable gc-cpu sstats-gc-cpu set-sstats-gc-cpu!)
|
|
(mutable gc-real sstats-gc-real set-sstats-gc-real!)
|
|
(mutable gc-bytes sstats-gc-bytes set-sstats-gc-bytes!))
|
|
(protocol
|
|
(lambda (new)
|
|
(lambda (cpu real bytes gc-count gc-cpu gc-real gc-bytes)
|
|
(new cpu real bytes gc-count gc-cpu gc-real gc-bytes))))))
|
|
(define exact-integer? (lambda (x) (and (integer? x) (exact? x))))
|
|
(set-who! make-sstats
|
|
(lambda (cpu real bytes gc-count gc-cpu gc-real gc-bytes)
|
|
(define verify-time
|
|
(lambda (name x)
|
|
(unless (time? x)
|
|
($oops who "~s value ~s is not a time record" name x))))
|
|
(define verify-exact-integer
|
|
(lambda (name x)
|
|
(unless (exact-integer? x)
|
|
($oops who "~s value ~s is not an exact integer" name x))))
|
|
(import sstats-record)
|
|
(verify-time 'cpu cpu)
|
|
(verify-time 'real real)
|
|
(verify-exact-integer 'bytes bytes)
|
|
(verify-exact-integer 'gc-count gc-count)
|
|
(verify-time 'gc-cpu gc-cpu)
|
|
(verify-time 'gc-real gc-real)
|
|
(verify-exact-integer 'gc-bytes gc-bytes)
|
|
(make-sstats cpu real bytes gc-count gc-cpu gc-real gc-bytes)))
|
|
(set! sstats? (lambda (x) (import sstats-record) (sstats? x)))
|
|
(let ()
|
|
(define verify-sstats
|
|
(lambda (who x)
|
|
(import sstats-record)
|
|
(unless (sstats? x) ($oops who "~s is not an sstats record" x))))
|
|
(define verify-exact-integer
|
|
(lambda (who x)
|
|
(unless (exact-integer? x)
|
|
($oops who "~s is not an exact integer" x))))
|
|
(define verify-time
|
|
(lambda (who x)
|
|
(unless (time? x)
|
|
($oops who "~s is not a time record" x))))
|
|
(define-syntax field
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ name verify-arg)
|
|
(with-syntax ([sstats-name (construct-name #'sstats-record "sstats-" #'name)]
|
|
[set-sstats-name! (construct-name #'sstats-record "set-sstats-" #'name "!")])
|
|
#'(begin
|
|
(set-who! sstats-name
|
|
(lambda (x)
|
|
(import sstats-record)
|
|
(verify-sstats who x)
|
|
(sstats-name x)))
|
|
(set-who! set-sstats-name!
|
|
(lambda (x n)
|
|
(import sstats-record)
|
|
(verify-sstats who x)
|
|
(verify-arg who n)
|
|
(set-sstats-name! x n)))))])))
|
|
(field cpu verify-time)
|
|
(field real verify-time)
|
|
(field bytes verify-exact-integer)
|
|
(field gc-count verify-exact-integer)
|
|
(field gc-cpu verify-time)
|
|
(field gc-real verify-time)
|
|
(field gc-bytes verify-exact-integer)))
|
|
|
|
(define-who sstats-print
|
|
(rec sstats-print
|
|
(case-lambda
|
|
[(s) (sstats-print s (current-output-port))]
|
|
[(s port)
|
|
(unless (sstats? s)
|
|
($oops who "~s is not an sstats record" s))
|
|
(unless (and (output-port? port) (textual-port? port))
|
|
($oops who "~s is not a textual output port" port))
|
|
(let ([collections (sstats-gc-count s)]
|
|
[time->string
|
|
(lambda (x)
|
|
;; based on record-writer for ts in date.ss
|
|
(let ([sec (time-second x)] [nsec (time-nanosecond x)])
|
|
(if (and (< sec 0) (> nsec 0))
|
|
(format "-~d.~9,'0ds" (- -1 sec) (- 1000000000 nsec))
|
|
(format "~d.~9,'0ds" sec nsec))))])
|
|
(if (zero? collections)
|
|
(fprintf port
|
|
" no collections
|
|
~a elapsed cpu time
|
|
~a elapsed real time
|
|
~s bytes allocated
|
|
"
|
|
(time->string (sstats-cpu s))
|
|
(time->string (sstats-real s))
|
|
(sstats-bytes s))
|
|
(fprintf port
|
|
" ~s collection~:p
|
|
~a elapsed cpu time, including ~a collecting
|
|
~a elapsed real time, including ~a collecting
|
|
~s bytes allocated, including ~s bytes reclaimed
|
|
"
|
|
collections
|
|
(time->string (sstats-cpu s)) (time->string (sstats-gc-cpu s))
|
|
(time->string (sstats-real s)) (time->string (sstats-gc-real s))
|
|
(sstats-bytes s) (sstats-gc-bytes s))))])))
|
|
|
|
(define display-statistics
|
|
(case-lambda
|
|
[() (display-statistics (current-output-port))]
|
|
[(p)
|
|
(unless (and (output-port? p) (textual-port? p))
|
|
($oops 'display-statistics "~s is not a textual output port" p))
|
|
(sstats-print (statistics) p)]))
|
|
|
|
(define-who sstats-difference
|
|
(lambda (a b)
|
|
(unless (sstats? a)
|
|
($oops who "~s is not an sstats record" a))
|
|
(unless (sstats? b)
|
|
($oops who "~s is not an sstats record" b))
|
|
(let ([int-diff (lambda (f a b) (- (f a) (f b)))]
|
|
[time-diff (lambda (f a b) (time-difference (f a) (f b)))])
|
|
(make-sstats
|
|
(time-diff sstats-cpu a b)
|
|
(time-diff sstats-real a b)
|
|
(int-diff sstats-bytes a b)
|
|
(int-diff sstats-gc-count a b)
|
|
(time-diff sstats-gc-cpu a b)
|
|
(time-diff sstats-gc-real a b)
|
|
(int-diff sstats-gc-bytes a b)))))
|
|
|
|
(define collect-generation-radix
|
|
(make-parameter
|
|
4
|
|
(lambda (v)
|
|
(unless (and (fixnum? v) (fx< 0 v))
|
|
($oops 'collect-generation-radix "~s is not a positive fixnum" v))
|
|
v)))
|
|
|
|
(define $reset-protect
|
|
(lambda (body out)
|
|
((call/cc
|
|
(lambda (k)
|
|
(parameterize ([reset-handler
|
|
(lambda ()
|
|
(k (lambda ()
|
|
(out)
|
|
((reset-handler)))))])
|
|
(with-exception-handler
|
|
(lambda (c)
|
|
; would prefer not to burn bridges even for serious condition
|
|
; if the exception is continuable, but we have no way to know
|
|
; short of grubbing through the continuation
|
|
(if (serious-condition? c)
|
|
(k (lambda () (out) (raise c)))
|
|
(raise-continuable c)))
|
|
(lambda ()
|
|
(call-with-values body
|
|
(case-lambda
|
|
[(v) (lambda () v)]
|
|
[v* (lambda () (apply values v*))]))))))))))
|
|
|
|
(define exit-handler)
|
|
(define reset-handler)
|
|
(define abort-handler)
|
|
(let ([c-exit (foreign-procedure "(cs)c_exit" (integer-32) void)])
|
|
(define (integer-32? x)
|
|
(and (integer? x)
|
|
(exact? x)
|
|
(<= #x-80000000 x #x7fffffff)))
|
|
|
|
(set! exit-handler
|
|
($make-thread-parameter
|
|
(case-lambda
|
|
[() (c-exit 0)]
|
|
[(x . args) (c-exit (if (eqv? x (void)) 0 (if (integer-32? x) x -1)))])
|
|
(lambda (v)
|
|
(unless (procedure? v)
|
|
($oops 'exit-handler "~s is not a procedure" v))
|
|
v)))
|
|
|
|
(set! reset-handler
|
|
($make-thread-parameter
|
|
(lambda () (c-exit 0))
|
|
(lambda (v)
|
|
(unless (procedure? v)
|
|
($oops 'reset-handler "~s is not a procedure" v))
|
|
v)))
|
|
|
|
(set! abort-handler
|
|
($make-thread-parameter
|
|
(case-lambda
|
|
[() (c-exit -1)]
|
|
[(x) (c-exit (if (eqv? x (void)) 0 (if (integer-32? x) x -1)))])
|
|
(lambda (v)
|
|
(unless (procedure? v)
|
|
($oops 'abort-handler "~s is not a procedure" v))
|
|
v))))
|
|
|
|
(let ()
|
|
(define (unexpected-return who)
|
|
($oops who (format "unexpected return from ~s handler" who)))
|
|
|
|
(set-who! exit
|
|
(lambda args
|
|
(apply (exit-handler) args)
|
|
(unexpected-return who)))
|
|
|
|
(set-who! #(r6rs: exit)
|
|
(case-lambda
|
|
[() ((exit-handler)) (unexpected-return who)]
|
|
[(x) ((exit-handler) x) (unexpected-return who)]))
|
|
|
|
(set-who! reset
|
|
(lambda ()
|
|
((reset-handler))
|
|
(unexpected-return who)))
|
|
|
|
(set-who! abort
|
|
(case-lambda
|
|
[() ((abort-handler)) (unexpected-return who)]
|
|
[(x) ((abort-handler) x) (unexpected-return who)])))
|
|
|
|
(define $interrupt ($make-thread-parameter void))
|
|
|
|
(define $format-scheme-version
|
|
(lambda (n)
|
|
(if (= (logand n 255) 0)
|
|
(format "~d.~d"
|
|
(ash n -16)
|
|
(logand (ash n -8) 255))
|
|
(format "~d.~d.~d"
|
|
(ash n -16)
|
|
(logand (ash n -8) 255)
|
|
(logand n 255)))))
|
|
|
|
; set in back.ss
|
|
(define $scheme-version)
|
|
|
|
(define scheme-version-number
|
|
(lambda ()
|
|
(let ([n (constant scheme-version)])
|
|
(values
|
|
(ash n -16)
|
|
(logand (ash n -8) 255)
|
|
(logand n 255)))))
|
|
|
|
(define scheme-version
|
|
(let ([s #f])
|
|
(lambda ()
|
|
(unless s
|
|
(set! s
|
|
(format "~:[Petite ~;~]Chez Scheme Version ~a"
|
|
$compiler-is-loaded?
|
|
$scheme-version)))
|
|
s)))
|
|
|
|
(define petite?
|
|
(lambda ()
|
|
(not $compiler-is-loaded?)))
|
|
|
|
(define threaded?
|
|
(lambda ()
|
|
(if-feature pthreads #t #f)))
|
|
|
|
(define get-process-id (foreign-procedure "(cs)getpid" () integer-32))
|
|
|
|
(set! get-thread-id
|
|
(lambda ()
|
|
($tc-field 'threadno ($tc))))
|
|
|
|
(define-who sleep
|
|
(let ([fp (foreign-procedure "(cs)nanosleep" (ptr ptr) void)])
|
|
(lambda (t)
|
|
(unless (and (time? t) (eq? (time-type t) 'time-duration))
|
|
($oops who "~s is not a time record of type time-duration" t))
|
|
(fp (time-second t) (time-nanosecond t)))))
|
|
|
|
(define $scheme-greeting
|
|
(lambda ()
|
|
(format "~a\nCopyright 1984-2019 Cisco Systems, Inc.\n"
|
|
(scheme-version))))
|
|
|
|
(define $session-key #f)
|
|
(define $scheme-init)
|
|
(define $scheme)
|
|
(define $script)
|
|
(define $as-time-goes-by)
|
|
(define collect)
|
|
(define break-handler)
|
|
(define debug)
|
|
|
|
(let ()
|
|
|
|
(define debug-condition* '())
|
|
|
|
(module (docollect collect-init)
|
|
(define gc-trip 0)
|
|
(define gc-cpu (make-time 'time-collector-cpu 0 0))
|
|
(define gc-real (make-time 'time-collector-real 0 0))
|
|
(define gc-bytes 0)
|
|
(define gc-count 0)
|
|
(define start-bytes 0)
|
|
(define docollect
|
|
(let ([do-gc (foreign-procedure "(cs)do_gc" (int int) void)])
|
|
(lambda (p)
|
|
(with-tc-mutex
|
|
(unless (= $active-threads 1)
|
|
($oops 'collect "cannot collect when multiple threads are active"))
|
|
(let-values ([(trip g gtarget) (p gc-trip)])
|
|
(set! gc-trip trip)
|
|
(let ([cpu (current-time 'time-thread)] [real (current-time 'time-monotonic)])
|
|
(set! gc-bytes (+ gc-bytes (bytes-allocated)))
|
|
(when (collect-notify)
|
|
(fprintf (console-output-port)
|
|
"~%[collecting generation ~s into generation ~s..."
|
|
g gtarget)
|
|
(flush-output-port (console-output-port)))
|
|
(when (eqv? g (collect-maximum-generation))
|
|
($clear-source-lines-cache))
|
|
(do-gc g gtarget)
|
|
($close-resurrected-files)
|
|
(when-feature pthreads
|
|
($close-resurrected-mutexes&conditions))
|
|
(when (collect-notify)
|
|
(fprintf (console-output-port) "done]~%")
|
|
(flush-output-port (console-output-port)))
|
|
(set! gc-bytes (- gc-bytes (bytes-allocated)))
|
|
(set! gc-cpu (add-duration gc-cpu (time-difference (current-time 'time-thread) cpu)))
|
|
(set! gc-real (add-duration gc-real (time-difference (current-time 'time-monotonic) real)))
|
|
(set! gc-count (1+ gc-count))))))))
|
|
(define collect-init
|
|
(lambda ()
|
|
(set! gc-trip 0)
|
|
(set! gc-cpu (make-time 'time-collector-cpu 0 0))
|
|
(set! gc-real (make-time 'time-collector-real 0 0))
|
|
(set! gc-count 0)
|
|
(set! gc-bytes 0)
|
|
(set! start-bytes (bytes-allocated))))
|
|
(set! $gc-real-time (lambda () gc-real))
|
|
(set! $gc-cpu-time (lambda () gc-cpu))
|
|
(set! initial-bytes-allocated (lambda () start-bytes))
|
|
(set! bytes-deallocated (lambda () gc-bytes))
|
|
(set! collections (lambda () gc-count))
|
|
(set! statistics
|
|
(lambda ()
|
|
(make-sstats
|
|
(current-time 'time-thread)
|
|
(current-time 'time-monotonic)
|
|
(+ (- (bytes-allocated) start-bytes) gc-bytes)
|
|
gc-count
|
|
gc-cpu
|
|
gc-real
|
|
gc-bytes))))
|
|
|
|
(set-who! collect
|
|
(let ()
|
|
(define collect0
|
|
(lambda ()
|
|
(docollect
|
|
(lambda (gct)
|
|
(let ([gct (+ gct 1)])
|
|
(let loop ([g (collect-maximum-generation)])
|
|
(if (= (modulo gct (expt (collect-generation-radix) g)) 0)
|
|
(if (fx= g (collect-maximum-generation))
|
|
(values 0 g g)
|
|
(values gct g (fx+ g 1)))
|
|
(loop (fx- g 1)))))))))
|
|
(define collect2
|
|
(lambda (g gtarget)
|
|
(docollect
|
|
(lambda (gct)
|
|
(values
|
|
; make gc-trip to look like we've just collected generation g
|
|
; w/o also having collected generation g+1
|
|
(if (fx= g (collect-maximum-generation))
|
|
0
|
|
(let ([gct (+ gct 1)])
|
|
(define (trip g)
|
|
(let ([n (expt (collect-generation-radix) g)])
|
|
(+ gct (modulo (- n gct) n))))
|
|
(let ([next (trip g)] [limit (trip (fx+ g 1))])
|
|
(if (< next limit) next (- limit 1)))))
|
|
g gtarget)))))
|
|
(case-lambda
|
|
[() (collect0)]
|
|
[(g)
|
|
(unless (and (fixnum? g) (fx<= 0 g (collect-maximum-generation)))
|
|
($oops who "invalid generation ~s" g))
|
|
(collect2 g (if (fx= g (collect-maximum-generation)) g (fx+ g 1)))]
|
|
[(g gtarget)
|
|
(unless (and (fixnum? g) (fx<= 0 g (collect-maximum-generation)))
|
|
($oops who "invalid generation ~s" g))
|
|
(unless (if (fx= g (collect-maximum-generation))
|
|
(or (eqv? gtarget g) (eq? gtarget 'static))
|
|
(or (eqv? gtarget g) (eqv? gtarget (fx+ g 1))))
|
|
($oops who "invalid target generation ~s for generation ~s" gtarget g))
|
|
(collect2 g (if (eq? gtarget 'static) (constant static-generation) gtarget))])))
|
|
|
|
(set! collect-rendezvous
|
|
(let ([fire-collector (foreign-procedure "(cs)fire_collector" () void)])
|
|
(lambda ()
|
|
(fire-collector)
|
|
($collect-rendezvous))))
|
|
|
|
(set! keyboard-interrupt-handler
|
|
($make-thread-parameter
|
|
(lambda ()
|
|
(clear-output-port (console-output-port))
|
|
(fresh-line (console-output-port))
|
|
(flush-output-port (console-output-port))
|
|
(($interrupt)))
|
|
(lambda (x)
|
|
(unless (procedure? x)
|
|
($oops 'keyboard-interrupt-handler "~s is not a procedure" x))
|
|
x)))
|
|
|
|
(let ()
|
|
(define register-scheme-signal
|
|
(foreign-procedure "(cs)register_scheme_signal" (iptr) void))
|
|
|
|
(define signal-alist '())
|
|
|
|
(set! register-signal-handler
|
|
(lambda (sig handler)
|
|
(unless (fixnum? sig)
|
|
($oops 'register-signal-handler "~s is not a fixnum" sig))
|
|
(unless (procedure? handler)
|
|
($oops 'register-signal-handler "~s is not a procedure" handler))
|
|
(critical-section
|
|
(register-scheme-signal sig)
|
|
(let ((a (assq sig signal-alist)))
|
|
(if a
|
|
(set-cdr! a handler)
|
|
(set! signal-alist (cons (cons sig handler) signal-alist)))))))
|
|
|
|
(set! $signal-interrupt-handler
|
|
(lambda (sig)
|
|
(let ((a (assq sig signal-alist)))
|
|
(unless a
|
|
($oops '$signal-interrupt-handler
|
|
"unexpected signal number ~d received~%"
|
|
sig))
|
|
((cdr a) sig)))))
|
|
|
|
;;; entry point from C kernel
|
|
|
|
(set! $scheme-init
|
|
(lambda ()
|
|
(set! debug-condition* '())
|
|
(collect-init)
|
|
($io-init)
|
|
(set! $session-key #f)
|
|
($interrupt reset)
|
|
($clear-pass-stats)
|
|
(enable-interrupts)))
|
|
|
|
(set! $scheme
|
|
(lambda (fns)
|
|
(define (go)
|
|
(call/cc
|
|
(lambda (k)
|
|
(parameterize ([abort-handler
|
|
(case-lambda [() (k -1)] [(x) (k x)])]
|
|
[exit-handler
|
|
(case-lambda [() (k (void))] [(x . args) (k x)])]
|
|
[reset-handler (lambda () (k -1))])
|
|
(apply (scheme-start) fns)))))
|
|
(unless (suppress-greeting)
|
|
(display ($scheme-greeting) (console-output-port))
|
|
(newline (console-output-port))
|
|
(flush-output-port (console-output-port)))
|
|
(if-feature expeditor
|
|
(if ($enable-expeditor) ($expeditor go) (go))
|
|
(go))))
|
|
|
|
(set! $script
|
|
(lambda (program? fn fns)
|
|
(define (go)
|
|
(call/cc
|
|
(lambda (k)
|
|
(parameterize ([abort-handler
|
|
(case-lambda [() (k -1)] [(x) (k x)])]
|
|
[exit-handler
|
|
(case-lambda [() (k (void))] [(x . args) (k x)])]
|
|
[reset-handler (lambda () (k -1))])
|
|
(apply (if program? (scheme-program) (scheme-script)) fn fns)))))
|
|
(if-feature expeditor
|
|
(if ($enable-expeditor) ($expeditor go) (go))
|
|
(go))))
|
|
|
|
(set! $as-time-goes-by
|
|
(lambda (e t)
|
|
(define sanitize
|
|
(lambda (s)
|
|
(define sanitize-time
|
|
(lambda (t)
|
|
(if (< (time-second t) 0)
|
|
(make-time 'time-duration 0 0)
|
|
t)))
|
|
(define sanitize-count
|
|
(lambda (n)
|
|
(max n 0)))
|
|
(make-sstats
|
|
(sanitize-time (sstats-cpu s))
|
|
(sanitize-time (sstats-real s))
|
|
(sanitize-count (sstats-bytes s))
|
|
(sanitize-count (sstats-gc-count s))
|
|
(sanitize-time (sstats-gc-cpu s))
|
|
(sanitize-time (sstats-gc-real s))
|
|
(sanitize-count (sstats-gc-bytes s)))))
|
|
(define prstats
|
|
(lambda (b1 b2)
|
|
(let ([a (statistics)])
|
|
(parameterize ([print-level 2] [print-length 2])
|
|
(fprintf (console-output-port) "(time ~s)~%" e))
|
|
(let ([elapsed (sstats-difference a b2)])
|
|
(let ([overhead (sstats-difference b2 b1)])
|
|
(let ([adjusted (sanitize (sstats-difference elapsed overhead))])
|
|
(sstats-print adjusted (console-output-port)))))
|
|
(flush-output-port (console-output-port)))))
|
|
(let ([b1 (statistics)])
|
|
(let ([b2 (statistics)])
|
|
(call-with-values t
|
|
(case-lambda
|
|
[(v) (prstats b1 b2) v]
|
|
[(v1 v2) (prstats b1 b2) (values v1 v2)]
|
|
[(v1 v2 v3) (prstats b1 b2) (values v1 v2 v3)]
|
|
[(v1 v2 v3 v4) (prstats b1 b2) (values v1 v2 v3 v4)]
|
|
[r (prstats b1 b2) (apply values r)]))))))
|
|
|
|
(set! $report-string
|
|
(lambda (dest what who msg args)
|
|
(let ([what (and (not (equal? what "")) what)]
|
|
[who (and (not (equal? who "")) who)])
|
|
(parameterize ([print-level 3] [print-length 6])
|
|
(format dest "~@[~@(~a~)~]~:[~; in ~]~@[~a~]~:[~;: ~]~@[~?~]"
|
|
what
|
|
(and what who)
|
|
who
|
|
(and (or what who) (not (equal? msg "")))
|
|
msg
|
|
args)))))
|
|
|
|
(let ()
|
|
(define report
|
|
(lambda (what who msg args)
|
|
(fresh-line (console-output-port))
|
|
($report-string (console-output-port) what who msg args)
|
|
(newline (console-output-port))
|
|
(flush-output-port (console-output-port))))
|
|
|
|
(set! break-handler
|
|
($make-thread-parameter
|
|
(case-lambda
|
|
[(who msg . args)
|
|
(unless (string? msg)
|
|
($oops 'default-break-handler "~s is not a string" msg))
|
|
(report "break" who msg args)
|
|
(($interrupt))]
|
|
[(who)
|
|
(report "break" who "" '())
|
|
(($interrupt))]
|
|
[()
|
|
(($interrupt))])
|
|
(lambda (x)
|
|
(unless (procedure? x)
|
|
($oops 'break-handler "~s is not a procedure" x))
|
|
x)))
|
|
)
|
|
|
|
(set-who! debug-condition
|
|
(case-lambda
|
|
[() (cond
|
|
[(assv ($tc-field 'threadno ($tc)) debug-condition*) => cdr]
|
|
[else #f])]
|
|
[(c)
|
|
(let ([n ($tc-field 'threadno ($tc))])
|
|
(with-tc-mutex
|
|
(set! debug-condition*
|
|
(let ([ls (remp (lambda (a) (eqv? (car a) n)) debug-condition*)])
|
|
(if c (cons (cons n c) ls) ls)))))]))
|
|
|
|
(set! debug
|
|
(lambda ()
|
|
(define line-limit 74)
|
|
(define pad
|
|
(lambda (s n p)
|
|
(let ([i (string-length s)])
|
|
(when (> n i) (display (make-string (- n i) #\space) p))
|
|
(display s p)
|
|
(max i n))))
|
|
(define numbered-line-display
|
|
(lambda (point? n c p)
|
|
(display (if point? "*" " "))
|
|
(let ([s (with-output-to-string (lambda () (display-condition c)))])
|
|
(let ([k (- line-limit (+ (pad (number->string n) 4 p) 2))])
|
|
(display ": " p)
|
|
(let ([i (string-length s)])
|
|
(if (> i k)
|
|
(fprintf p "~a ...~%" (substring s 0 (- k 4)))
|
|
(fprintf p "~a~%" s)))))))
|
|
(define unnumbered-line-display
|
|
(lambda (c p)
|
|
(let ([s (with-output-to-string (lambda () (display-condition c)))])
|
|
(let ([k (- line-limit 2)])
|
|
(display " " p)
|
|
(let ([i (string-length s)])
|
|
(if (> i k)
|
|
(fprintf p "~a ...~%" (substring s 0 (- k 4)))
|
|
(fprintf p "~a~%" s)))))))
|
|
(define printem
|
|
(lambda (point ls p)
|
|
(if (null? (cdr ls))
|
|
(let ([x (car ls)])
|
|
(unnumbered-line-display (cdr x) p))
|
|
(for-each
|
|
(lambda (x)
|
|
(numbered-line-display (eq? x point) (car x) (cdr x) p))
|
|
ls))))
|
|
(define debug-cafe
|
|
(lambda (point ls)
|
|
(parameterize ([$interrupt void])
|
|
(clear-input-port (console-input-port))
|
|
(let ([waiter (call/cc
|
|
(lambda (k)
|
|
(rec f (lambda () (k f)))))])
|
|
(fprintf (console-output-port) "debug> ")
|
|
(flush-output-port (console-output-port))
|
|
(let ([x (let ([x (parameterize ([$interrupt waiter]
|
|
[reset-handler waiter])
|
|
(read (console-input-port)))])
|
|
(if (eof-object? x)
|
|
(begin
|
|
(newline (console-output-port))
|
|
(flush-output-port (console-output-port))
|
|
'e)
|
|
x))])
|
|
(case x
|
|
[(i)
|
|
(let ([c (cdr point)])
|
|
(if (continuation-condition? c)
|
|
(inspect (condition-continuation c))
|
|
(display "the raise continuation is not available\n")))
|
|
(waiter)]
|
|
[(c)
|
|
(inspect (cdr point))
|
|
(waiter)]
|
|
[(q)
|
|
(with-tc-mutex
|
|
(for-each
|
|
(lambda (x) (set! debug-condition* (remq x debug-condition*)))
|
|
ls))
|
|
(void)]
|
|
[(e)
|
|
(void)]
|
|
[(s)
|
|
(printem point
|
|
(sort (lambda (x y) (< (car x) (car y))) ls)
|
|
(console-output-port))
|
|
(waiter)]
|
|
[(?)
|
|
(if (null? (cdr ls))
|
|
(fprintf (console-output-port)
|
|
"Type i to inspect the raise continuation (if available)
|
|
s to display the condition
|
|
c to inspect the condition
|
|
e or eof to exit the debugger, retaining error continuation
|
|
q to exit the debugger, discarding error continuation
|
|
")
|
|
(fprintf (console-output-port)
|
|
"Type i to inspect the selected thread's raise continuation (if available)
|
|
<n> to select thread <n>
|
|
s to display the conditions
|
|
c to inspect the selected thread's condition
|
|
e or eof to exit the debugger, retaining error continuations
|
|
q to exit the debugger, discarding error continuations
|
|
"))
|
|
(flush-output-port (console-output-port))
|
|
(waiter)]
|
|
[else
|
|
(cond
|
|
[(assv x ls) =>
|
|
(lambda (a)
|
|
(set! point a)
|
|
(waiter))]
|
|
[(and (integer? x) (nonnegative? x))
|
|
(fprintf (console-output-port)
|
|
"No saved error continution for thread ~s.~%"
|
|
x)
|
|
(flush-output-port (console-output-port))
|
|
(waiter)]
|
|
[else
|
|
(fprintf (console-output-port)
|
|
"Invalid command. Type ? for options.~%")
|
|
(flush-output-port (console-output-port))
|
|
(waiter)])]))))))
|
|
(let ([ls debug-condition*])
|
|
(cond
|
|
[(null? ls)
|
|
(fprintf (console-output-port) "Nothing to debug.~%")
|
|
(flush-output-port (console-output-port))]
|
|
[else
|
|
(debug-cafe (car ls) ls)]))))
|
|
)
|
|
|
|
(define $collect-rendezvous
|
|
(lambda ()
|
|
(define once
|
|
(let ([once #f])
|
|
(lambda ()
|
|
(when (eq? once #t)
|
|
($oops '$collect-rendezvous
|
|
"cannot return to the collect-request-handler"))
|
|
(set! once #t))))
|
|
(if-feature pthreads
|
|
(with-tc-mutex
|
|
(let f ()
|
|
(when $collect-request-pending
|
|
(if (= $active-threads 1) ; last one standing
|
|
(dynamic-wind
|
|
once
|
|
(collect-request-handler)
|
|
(lambda ()
|
|
(set! $collect-request-pending #f)
|
|
(condition-broadcast $collect-cond)))
|
|
(begin
|
|
(condition-wait $collect-cond $tc-mutex)
|
|
(f))))))
|
|
(critical-section
|
|
(dynamic-wind
|
|
once
|
|
(collect-request-handler)
|
|
(lambda () (set! $collect-request-pending #f)))))))
|
|
|
|
(define collect-request-handler
|
|
(make-parameter
|
|
(lambda () (collect))
|
|
(lambda (x)
|
|
(unless (procedure? x)
|
|
($oops 'collect-request-handler "~s is not a procedure" x))
|
|
x)))
|
|
|
|
(define collect-notify (make-parameter #f (lambda (x) (and x #t))))
|
|
|
|
(define $c-error
|
|
(lambda (arg . error-args)
|
|
; error-args may be present along doargerr path, but we presently
|
|
; ignore them
|
|
(define-syntax c-error-case
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ arg [(key) fmls e1 e2 ...] ...)
|
|
(with-syntax ([(k ...) (map lookup-constant (datum (key ...)))])
|
|
#'(let ([t arg])
|
|
(record-case t
|
|
[(k) fmls e1 e2 ...]
|
|
...
|
|
[else ($oops '$c-error "invalid error type ~s" t)])))])))
|
|
(c-error-case arg
|
|
[(ERROR_OTHER) args (apply $oops args)]
|
|
[(ERROR_CALL_UNBOUND) (cnt symbol arg1?)
|
|
($oops #f "variable ~:s is not bound" symbol)]
|
|
[(ERROR_CALL_NONPROCEDURE_SYMBOL) (cnt symbol arg1?)
|
|
($oops #f "attempt to apply non-procedure ~s"
|
|
($top-level-value symbol))]
|
|
[(ERROR_CALL_NONPROCEDURE) (cnt nonprocedure arg1?)
|
|
($oops #f "attempt to apply non-procedure ~s" nonprocedure)]
|
|
[(ERROR_CALL_ARGUMENT_COUNT) (cnt procedure arg1?)
|
|
($oops #f "incorrect number of arguments to ~s" procedure)]
|
|
[(ERROR_RESET) (who msg . args)
|
|
($oops who "~?. Some debugging context lost" msg args)]
|
|
[(ERROR_NONCONTINUABLE_INTERRUPT) args
|
|
(let ([noncontinuable-interrupt
|
|
(lambda ()
|
|
((keyboard-interrupt-handler))
|
|
(fprintf (console-output-port)
|
|
"Noncontinuable interrupt.~%")
|
|
(reset))])
|
|
;; ruse to get inspector to print "continuation in
|
|
;; noncontinuable-interrupt" instead of "#c-error".
|
|
(noncontinuable-interrupt))]
|
|
[(ERROR_VALUES) (cnt)
|
|
($oops #f
|
|
"returned ~r values to single value return context"
|
|
cnt)]
|
|
[(ERROR_MVLET) (cnt)
|
|
($oops #f
|
|
"incorrect number of values received in multiple value context")])))
|
|
|
|
(define break
|
|
(lambda args
|
|
(apply (break-handler) args)))
|
|
|
|
(define timer-interrupt-handler
|
|
($make-thread-parameter
|
|
(lambda ()
|
|
($oops 'timer-interrupt
|
|
"timer interrupt occurred with no handler defined"))
|
|
(lambda (x)
|
|
(unless (procedure? x)
|
|
($oops 'timer-interrupt-handler "~s is not a procedure" x))
|
|
x)))
|
|
|
|
(define $symbol-type
|
|
(lambda (name)
|
|
(let ((flags ($sgetprop name '*flags* 0)))
|
|
(cond
|
|
[(any-set? (prim-mask system) flags) 'system]
|
|
[(any-set? (prim-mask primitive) flags) 'primitive]
|
|
[(any-set? (prim-mask keyword) flags)
|
|
(if (any-set? (prim-mask library-uid) flags)
|
|
'library-uid
|
|
'keyword)]
|
|
[(any-set? (prim-mask system-keyword) flags)
|
|
(if (any-set? (prim-mask library-uid) flags)
|
|
'system-library-uid
|
|
'system-keyword)]
|
|
[else 'unknown]))))
|
|
|
|
(let ()
|
|
; naive version is good enough for apropos
|
|
(define (substring? s1 s2)
|
|
(let ([n1 (string-length s1)] [n2 (string-length s2)])
|
|
(let loop2 ([i2 0])
|
|
(let loop1 ([i1 0] [j i2])
|
|
(if (fx= i1 n1)
|
|
i2
|
|
(and (not (fx= j n2))
|
|
(if (char=? (string-ref s1 i1) (string-ref s2 j))
|
|
(loop1 (fx+ i1 1) (fx+ j 1))
|
|
(loop2 (fx+ i2 1)))))))))
|
|
(define sym<? (lambda (x y) (string-ci<? (symbol->string x) (symbol->string y))))
|
|
(define apropos-help
|
|
(lambda (s env)
|
|
(let ([s (if (symbol? s) (symbol->string s) s)])
|
|
(sort sym<?
|
|
(let f ([ls (environment-symbols env)])
|
|
(if (null? ls)
|
|
'()
|
|
(if (substring? s (symbol->string (car ls)))
|
|
(cons (car ls) (f (cdr ls)))
|
|
(f (cdr ls)))))))))
|
|
(define apropos-library-help
|
|
(lambda (s)
|
|
(define lib<?
|
|
(lambda (lib1 lib2)
|
|
(and (not (null? lib2))
|
|
(or (null? lib1)
|
|
(if (eq? (car lib1) (car lib2))
|
|
(lib<? (cdr lib1) (cdr lib2))
|
|
(sym<? (car lib1) (car lib2)))))))
|
|
(let ([s (if (symbol? s) (symbol->string s) s)])
|
|
(sort (lambda (ls1 ls2) (lib<? (car ls1) (car ls2)))
|
|
(let do-libs ([lib* (library-list)] [match** '()])
|
|
(if (null? lib*)
|
|
match**
|
|
(do-libs (cdr lib*)
|
|
(let do-exports ([x* (library-exports (car lib*))] [match* '()])
|
|
(if (null? x*)
|
|
(if (null? match*)
|
|
match**
|
|
(cons (cons (car lib*) (sort sym<? match*)) match**))
|
|
(do-exports (cdr x*)
|
|
(if (substring? s (symbol->string (car x*)))
|
|
(cons (car x*) match*)
|
|
match*)))))))))))
|
|
(define check-s
|
|
(lambda (who s)
|
|
(unless (or (symbol? s) (string? s))
|
|
($oops who "~s is not a symbol or string" s))))
|
|
(define check-env
|
|
(lambda (who env)
|
|
(unless (environment? env)
|
|
($oops 'apropos-list "~s is not an environment" env))))
|
|
(set! apropos-list
|
|
(case-lambda
|
|
[(s)
|
|
(check-s 'apropos-list s)
|
|
(append
|
|
(apropos-help s (interaction-environment))
|
|
(apropos-library-help s))]
|
|
[(s env)
|
|
(check-s 'apropos-list s)
|
|
(check-env 'apropos-list env)
|
|
(append
|
|
(apropos-help s env)
|
|
(apropos-library-help s))]))
|
|
(let ()
|
|
(define do-apropos
|
|
(lambda (who where s env)
|
|
(printf "~a environment:\n ~{~<~%~& ~1:; ~s~>~^,~}~&" where (apropos-help s env))
|
|
(for-each
|
|
(lambda (x) (printf "~s:\n ~{~<~%~& ~1:; ~s~>~^,~}~&" (car x) (cdr x)))
|
|
(apropos-library-help s))))
|
|
(set-who! apropos
|
|
(case-lambda
|
|
[(s)
|
|
(check-s who s)
|
|
(do-apropos who "interaction" s (interaction-environment))]
|
|
[(s env)
|
|
(check-s who s)
|
|
(check-env who env)
|
|
(do-apropos who "supplied" s env)]))))
|
|
|
|
(let ()
|
|
(define-record-type pass-stats
|
|
(nongenerative)
|
|
(sealed #t)
|
|
(fields
|
|
(mutable calls)
|
|
(mutable cpu)
|
|
(mutable gc-cpu)
|
|
(mutable bytes))
|
|
(protocol
|
|
(lambda (n)
|
|
(lambda ()
|
|
(let ([t (make-time 'time-duration 0 0)])
|
|
(n 0 t t 0))))))
|
|
|
|
(define field-names '(name calls cpu gc-cpu bytes))
|
|
|
|
(define stats-ht)
|
|
|
|
(define-threaded outer-ps #f)
|
|
|
|
(set! $clear-pass-stats
|
|
(lambda ()
|
|
(set! stats-ht (make-eq-hashtable))))
|
|
|
|
(set! $enable-pass-timing (make-parameter #f))
|
|
|
|
(set-who! $pass-time
|
|
(lambda (name thunk)
|
|
(unless (symbol? name) ($oops who "~s is not a symbol" name))
|
|
(unless (procedure? thunk) ($oops who "~s is not a procedure" thunk))
|
|
(if ($enable-pass-timing)
|
|
(let ([ps (with-tc-mutex
|
|
(let ([a (hashtable-cell stats-ht name #f)])
|
|
(let ([ps (or (cdr a) (let ([ps (make-pass-stats)]) (set-cdr! a ps) ps))])
|
|
(pass-stats-calls-set! ps (+ (pass-stats-calls ps) 1))
|
|
ps)))])
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(with-tc-mutex
|
|
(let ([cpu (current-time 'time-thread)]
|
|
[gc-cpu (current-time 'time-collector-cpu)]
|
|
[bytes (+ (bytes-deallocated) (bytes-allocated))])
|
|
(set-time-type! cpu 'time-duration)
|
|
(set-time-type! gc-cpu 'time-duration)
|
|
(when outer-ps
|
|
(pass-stats-cpu-set! outer-ps (add-duration (pass-stats-cpu outer-ps) cpu))
|
|
(pass-stats-gc-cpu-set! outer-ps (add-duration (pass-stats-gc-cpu outer-ps) gc-cpu))
|
|
(pass-stats-bytes-set! outer-ps (+ (pass-stats-bytes outer-ps) bytes)))
|
|
(pass-stats-cpu-set! ps (subtract-duration (pass-stats-cpu ps) cpu))
|
|
(pass-stats-gc-cpu-set! ps (subtract-duration (pass-stats-gc-cpu ps) gc-cpu))
|
|
(pass-stats-bytes-set! ps (- (pass-stats-bytes ps) bytes)))))
|
|
(lambda () (fluid-let ([outer-ps ps]) (thunk)))
|
|
(lambda ()
|
|
(with-tc-mutex
|
|
(let ([cpu (current-time 'time-thread)]
|
|
[gc-cpu (current-time 'time-collector-cpu)]
|
|
[bytes (+ (bytes-deallocated) (bytes-allocated))])
|
|
(set-time-type! cpu 'time-duration)
|
|
(set-time-type! gc-cpu 'time-duration)
|
|
(when outer-ps
|
|
(pass-stats-cpu-set! outer-ps (subtract-duration (pass-stats-cpu outer-ps) cpu))
|
|
(pass-stats-gc-cpu-set! outer-ps (subtract-duration (pass-stats-gc-cpu outer-ps) gc-cpu))
|
|
(pass-stats-bytes-set! outer-ps (- (pass-stats-bytes outer-ps) bytes)))
|
|
(pass-stats-cpu-set! ps (add-duration (pass-stats-cpu ps) cpu))
|
|
(pass-stats-gc-cpu-set! ps (add-duration (pass-stats-gc-cpu ps) gc-cpu))
|
|
(pass-stats-bytes-set! ps (+ (pass-stats-bytes ps) bytes)))))))
|
|
(thunk))))
|
|
|
|
(set-who! $pass-stats-fields (lambda () field-names))
|
|
|
|
(set! $pass-stats
|
|
(lambda ()
|
|
(define (build-result namev psv)
|
|
(vector->list
|
|
(vector-map
|
|
(lambda (name ps)
|
|
(list name
|
|
(pass-stats-calls ps)
|
|
(pass-stats-cpu ps)
|
|
(pass-stats-gc-cpu ps)
|
|
(pass-stats-bytes ps)))
|
|
namev
|
|
psv)))
|
|
(with-tc-mutex
|
|
(if outer-ps
|
|
(let ([cpu (current-time 'time-thread)]
|
|
[gc-cpu (current-time 'time-collector-cpu)]
|
|
[bytes (+ (bytes-deallocated) (bytes-allocated))])
|
|
(set-time-type! cpu 'time-duration)
|
|
(set-time-type! gc-cpu 'time-duration)
|
|
(pass-stats-cpu-set! outer-ps (add-duration (pass-stats-cpu outer-ps) cpu))
|
|
(pass-stats-gc-cpu-set! outer-ps (add-duration (pass-stats-gc-cpu outer-ps) gc-cpu))
|
|
(pass-stats-bytes-set! outer-ps (+ (pass-stats-bytes outer-ps) bytes))
|
|
(let ([result (call-with-values (lambda () (hashtable-entries stats-ht)) build-result)])
|
|
(pass-stats-cpu-set! outer-ps (subtract-duration (pass-stats-cpu outer-ps) cpu))
|
|
(pass-stats-gc-cpu-set! outer-ps (subtract-duration (pass-stats-gc-cpu outer-ps) gc-cpu))
|
|
(pass-stats-bytes-set! outer-ps (- (pass-stats-bytes outer-ps) bytes))
|
|
result))
|
|
(call-with-values (lambda () (hashtable-entries stats-ht)) build-result)))))
|
|
|
|
(let ()
|
|
(define who '$print-pass-stats)
|
|
(define field-name-strings (map symbol->string field-names))
|
|
(define check-psls
|
|
(lambda (psl*)
|
|
(unless (list? psl*) ($oops who "~s is not a list" psl*))
|
|
(for-each
|
|
(lambda (psl)
|
|
(define exact-integer? (lambda (x) (or (fixnum? x) (bignum? x))))
|
|
(unless (and (fx= ($list-length psl who) 5)
|
|
(apply (lambda (name calls cpu gc-cpu bytes)
|
|
(and (exact-integer? calls)
|
|
(time? cpu)
|
|
(time? gc-cpu)
|
|
(exact-integer? bytes)))
|
|
psl))
|
|
($oops who "malformed pass-stats entry ~s" psl)))
|
|
psl*)))
|
|
(define val->string
|
|
(lambda (x)
|
|
(cond
|
|
[(time? x)
|
|
(let-values ([(sec nsec)
|
|
(let ([sec (time-second x)] [nsec (time-nanosecond x)])
|
|
(if (and (< sec 0) (> nsec 0))
|
|
(values (+ sec 1) (- 1000000000 nsec))
|
|
(values sec nsec)))])
|
|
(format "~d.~9,'0d" sec nsec))]
|
|
[else (format "~s" x)])))
|
|
(define (print-pass-stats key psl*)
|
|
(define psl<?
|
|
(lambda (x y)
|
|
(apply (lambda (x-name x-calls x-cpu x-gc-cpu x-bytes)
|
|
(apply (lambda (y-name y-calls y-cpu y-gc-cpu y-bytes)
|
|
(case (or key 'non-gc-cpu)
|
|
[(non-gc-cpu)
|
|
(time<?
|
|
(time-difference x-cpu x-gc-cpu)
|
|
(time-difference y-cpu y-gc-cpu))]
|
|
[(cpu) (time<? x-cpu y-cpu)]
|
|
[(gc-cpu) (time<? x-gc-cpu y-gc-cpu)]
|
|
[(bytes) (< x-bytes y-bytes)]
|
|
[(name) (string<? (symbol->string x-name) (symbol->string y-name))]
|
|
[(calls) (< x-calls y-calls)]
|
|
[else ($oops who "unrecognized sort key ~s" key)]))
|
|
y))
|
|
x)))
|
|
; run check when passed psl* to check psl*; run when passed
|
|
; the value of ($pass-stats) to check our assumptions
|
|
(check-psls psl*)
|
|
(let ([psl* (append (sort psl<? psl*)
|
|
(list (let loop ([psl* psl*] [calls 0] [cpu (make-time 'time-duration 0 0)] [gc-cpu (make-time 'time-duration 0 0)] [bytes 0])
|
|
(if (null? psl*)
|
|
(list 'TOTAL calls cpu gc-cpu bytes)
|
|
(apply (lambda (*name *calls *cpu *gc-cpu *bytes)
|
|
(loop (cdr psl*)
|
|
(+ calls *calls)
|
|
(add-duration cpu *cpu)
|
|
(add-duration gc-cpu *gc-cpu)
|
|
(+ bytes *bytes)))
|
|
(car psl*))))))])
|
|
(let ([s** (map (lambda (psl) (map val->string psl)) psl*)])
|
|
(let ([w* (fold-left (lambda (w* s*)
|
|
(map (lambda (s w) (fxmax (string-length s) w)) s* w*))
|
|
(map string-length field-name-strings)
|
|
s**)])
|
|
(define print-row
|
|
(lambda (s*)
|
|
(printf "~v<~a~;~> " (car w*) (car s*))
|
|
(for-each (lambda (s w) (printf "~v:<~a~> " w s)) (cdr s*) (cdr w*))
|
|
(newline)))
|
|
(print-row field-name-strings)
|
|
(print-row (map (lambda (w) (make-string w #\-)) w*))
|
|
(for-each print-row s**)))))
|
|
(set! $print-pass-stats
|
|
(case-lambda
|
|
[() (print-pass-stats #f ($pass-stats))]
|
|
[(key) (print-pass-stats key ($pass-stats))]
|
|
[(key psl*) (print-pass-stats key psl*)]))))
|