diff --git a/pkgs/racket-doc/scribblings/foreign/alloc.scrbl b/pkgs/racket-doc/scribblings/foreign/alloc.scrbl index 329f1b9af2..34d7b2c767 100644 --- a/pkgs/racket-doc/scribblings/foreign/alloc.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/alloc.scrbl @@ -13,7 +13,7 @@ deallocated.} Produces a procedure that behaves like @racket[alloc], but the result of @racket[alloc] is given a finalizer that calls @racket[dealloc] on -the result if it is not otherwise freed through a deallocator (as +a non-@racket[#f] result if it is not otherwise freed through a deallocator (as designated with @racket[deallocator]). In addition, @racket[alloc] is called in @tech{atomic mode} (see @racket[call-as-atomic]); its result is received and registered in atomic mode, so that the result is reliably diff --git a/pkgs/racket-doc/scribblings/inside/values.scrbl b/pkgs/racket-doc/scribblings/inside/values.scrbl index e484fa0f7d..11e9af9c9c 100644 --- a/pkgs/racket-doc/scribblings/inside/values.scrbl +++ b/pkgs/racket-doc/scribblings/inside/values.scrbl @@ -186,13 +186,15 @@ types: extracts/sets the user data pointer; test for just this type with @cppdef{SCHEME_INPORTP}, but use @cppdef{SCHEME_INPUT_PORTP} to recognize all input ports (including structures with the - @racket[prop:input-port] property)} + @racket[prop:input-port] property), and use @cppi{scheme_input_port_record} + to extract a @cppi{scheme_input_port_type} value from a general input port} @item{@cppdef{scheme_output_port_type} --- @cppdef{SCHEME_OUTPORT_VAL} extracts/sets the user data pointer; test for just this type with @cppdef{SCHEME_OUTPORTP}, but use @cppdef{SCHEME_OUTPUT_PORTP} to recognize all output ports (including structures with the - @racket[prop:output-port] property)} + @racket[prop:output-port] property), and use @cppi{scheme_output_port_record} + to extract a @cppi{scheme_output_port_type} value from a general input port} @item{@cppdef{scheme_thread_type} --- thread descriptors; test for this type with @cppdef{SCHEME_THREADP}} diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl index 94324390bb..1b748b6e54 100644 --- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -164,7 +164,7 @@ For example, 2)] The generator argument adds a generator for the flat-named-contract. See -@racket[contract-generate] for more information. +@racket[contract-random-generate] for more information. } @defthing[any/c flat-contract?]{ diff --git a/pkgs/racket-doc/scribblings/reference/eval-model.scrbl b/pkgs/racket-doc/scribblings/reference/eval-model.scrbl index 42c89f0def..63b59191ed 100644 --- a/pkgs/racket-doc/scribblings/reference/eval-model.scrbl +++ b/pkgs/racket-doc/scribblings/reference/eval-model.scrbl @@ -791,9 +791,10 @@ binding is not included in the @tech{lexical information} for the module body. If a new variable definition has a counterpart in the old declaration, it effectively assigns to the old variable. -If a module is @tech{instantiate}d in any @tech{phase}s before it is -redeclared, each redeclaration of the module is immediately -@tech{instantiate}d in the same @tech{phase}s. +If a module is @tech{instantiate}d in the current namespace's +@tech{base phase} before the module is redeclared, the redeclaration +of the module is immediately @tech{instantiate}d in that +@tech{phase}. If the current @tech{inspector} does not manage a module's declaration inspector (see @secref["modprotect"]), then the module cannot be diff --git a/pkgs/racket-doc/scribblings/reference/memory.scrbl b/pkgs/racket-doc/scribblings/reference/memory.scrbl index 4f5f76ef16..1b965329d2 100644 --- a/pkgs/racket-doc/scribblings/reference/memory.scrbl +++ b/pkgs/racket-doc/scribblings/reference/memory.scrbl @@ -350,24 +350,42 @@ garbage-collection mode, depending on @racket[request]: #:changed "6.3.0.2" @elem{Added @racket['incremental] mode.}]} -@defproc[(current-memory-use [cust custodian? #f]) exact-nonnegative-integer?]{ +@defproc[(current-memory-use [mode (or/c #f 'cumulative custodian?) #f]) + exact-nonnegative-integer?]{ -Returns an estimate of the number of bytes of memory occupied by -reachable data from @racket[cust]. This estimate is calculated by the -last garbage collection, and can be 0 if none occurred (or if none occurred -since the given custodian was created). The @racket[current-memory-use] -function does @italic{not} perform a collection by itself; doing one -before the call will generally decrease the result (or increase it from -0 if no collections happened yet). +Returns information about memory use: -If @racket[cust] is not provided, the estimate is a total reachable from -any custodians. +@itemlist[ -When Racket is compiled without support for memory accounting, the -estimate is the same (i.e., all memory) for any individual custodian; -see also @racket[custodian-memory-accounting-available?]. + @item{If @racket[mode] is @racket[#f] (the default), the result is an + estimate of the number of bytes reachable from any custodian.} + + @item{If @racket[mode] is @racket['cumulative], returns an estimate + of the total number of bytes allocated since start up, + including bytes that have since been reclaimed by garbage + collection.} + + @item{If @racket[mode] is a custodian, returns an estimate of the + number of bytes of memory occupied by reachable data from + @racket[mode]. This estimate is calculated by the last garbage + collection, and can be 0 if none occurred (or if none occurred + since the given custodian was created). The + @racket[current-memory-use] function does @italic{not} perform + a collection by itself; doing one before the call will + generally decrease the result (or increase it from 0 if no + collections happened yet). + + When Racket is compiled without support for memory accounting, + the estimate is the same as when @racket[mode] is @racket[#f] + (i.e., all memory) for any individual custodian. See also + @racket[custodian-memory-accounting-available?].} + +] + +See also @racket[vector-set-performance-stats!]. + +@history[#:changed "6.6.0.3" @elem{Added @racket['cumulative] mode.}]} -See also @racket[vector-set-performance-stats!].} @defproc[(dump-memory-stats [v any/c] ...) any]{ diff --git a/pkgs/racket-doc/scribblings/reference/namespaces.scrbl b/pkgs/racket-doc/scribblings/reference/namespaces.scrbl index f4e48dc300..a412e234d2 100644 --- a/pkgs/racket-doc/scribblings/reference/namespaces.scrbl +++ b/pkgs/racket-doc/scribblings/reference/namespaces.scrbl @@ -22,7 +22,8 @@ otherwise.} @defproc[(make-empty-namespace) namespace?]{ Creates a new @tech{namespace} that is empty, and whose @tech{module -registry} contains no mappings. The namespace's @tech{base phase} is +registry} contains only mappings for some internal, predefined modules, +such as @racket['#%kernel]. The namespace's @tech{base phase} is the same as the @tech{base phase} of the @tech{current namespace}. Attach modules from an existing namespace to the new one with @racket[namespace-attach-module]. @@ -207,9 +208,9 @@ corresponding to the @tech{namespace}'s @tech{base phase}.} Performs the import corresponding to @racket[quoted-raw-require-spec] in the top-level environment of the current namespace, like a top-level @racket[#%require]. The @racket[quoted-raw-require-spec] -argument must be a datum that corresponds to a quoted +argument must be either a datum that corresponds to a quoted @racket[_raw-require-spec] for @racket[#%require], which includes -module paths. +module paths, or it can be a @tech{resolved module path}. Module paths in @racket[quoted-raw-require-spec] are resolved with respect to @racket[current-load-relative-directory] or @@ -249,7 +250,7 @@ undefined.} @defproc[(namespace-attach-module [src-namespace namespace?] - [modname module-path?] + [modname (or module-path? resolved-module-path?)] [dest-namespace namespace? (current-namespace)]) void?]{ @@ -330,7 +331,7 @@ Changes the inspector for the instance of the module referenced by that it is controlled by the current code inspector. The given @racket[inspector] must currently control the invocation of the module in @racket[namespace]'s @tech{module registry}, otherwise the -@exnraise[exn:fail:contract]. See also @secref["modprotect"].} +inspector is not changed. See also @secref["modprotect"].} @defproc[(namespace-module-registry [namespace namespace?]) diff --git a/pkgs/racket-doc/scribblings/reference/pretty-print.scrbl b/pkgs/racket-doc/scribblings/reference/pretty-print.scrbl index 4b557d49e1..5eb68ff7c1 100644 --- a/pkgs/racket-doc/scribblings/reference/pretty-print.scrbl +++ b/pkgs/racket-doc/scribblings/reference/pretty-print.scrbl @@ -6,14 +6,16 @@ @note-lib[racket/pretty] @defproc[(pretty-print [v any/c] [port output-port? (current-output-port)] - [quote-depth (or/c 0 1) 0]) + [quote-depth (or/c 0 1) 0] + [#:newline? newline? boolean? #t]) void?]{ Pretty-prints the value @racket[v] using the same printed form as the default @racket[print] mode, but with newlines and whitespace inserted to avoid lines longer than @racket[(pretty-print-columns)], as controlled by @racket[(pretty-print-current-style-table)]. The printed -form ends in a newline, unless the @racket[pretty-print-columns] +form ends in a newline by default, unless the @racket[newline?] +argument is supplied with false or the @racket[pretty-print-columns] parameter is set to @racket['infinity]. When @racket[port] has line counting enabled (see @secref["linecol"]), then printing is sensitive to the column when printing starts---both for determining an initial @@ -39,19 +41,36 @@ to determine the target printing width, and use function in the @racket[pretty-print-print-line] parameter can be called appropriately). Use @racket[make-tentative-pretty-print-output-port] to obtain a port for -tentative recursive prints (e.g., to check the length of the output).} +tentative recursive prints (e.g., to check the length of the output). -@defproc[(pretty-write [v any/c] [port output-port? (current-output-port)]) +If the @racket[newline?] argument is ommitted or supplied with true, +the @racket[pretty-print-print-line] callback is called with false as +the first argument to print the last newline after the printed value. +If it is supplied with false, the @racket[pretty-print-print-line] +callback is not called after the printed value. + +@history[#:changed "6.6.0.3" @elem{Added @racket[newline?] argument.}] +} + +@defproc[(pretty-write [v any/c] [port output-port? (current-output-port)] + [#:newline? newline? boolean? #t]) void?]{ Same as @racket[pretty-print], but @racket[v] is printed like -@racket[write] instead of like @racket[print].} +@racket[write] instead of like @racket[print]. -@defproc[(pretty-display [v any/c] [port output-port? (current-output-port)]) +@history[#:changed "6.6.0.3" @elem{Added @racket[newline?] argument.}] +} + +@defproc[(pretty-display [v any/c] [port output-port? (current-output-port)] + [#:newline? newline? boolean? #t]) void?]{ Same as @racket[pretty-print], but @racket[v] is printed like -@racket[display] instead of like @racket[print].} +@racket[display] instead of like @racket[print]. + +@history[#:changed "6.6.0.3" @elem{Added @racket[newline?] argument.}] +} @defproc[(pretty-format [v any/c] [columns exact-nonnegative-integer? (pretty-print-columns)] @@ -243,15 +262,18 @@ beginning of the new line. The @racket[proc] procedure is called before any characters are printed with @racket[0] as the line number and @racket[0] as the old -line length; @racket[proc] is called after the last character of a -value has been printed with @racket[#f] as the line number and with the -length of the last line. Whenever the pretty-printer starts a new -line, @racket[proc] is called with the new line's number (where the -first new line is numbered @racket[1]) and the just-finished line's -length. The destination-columns argument to @racket[proc] is always +line length. Whenever the pretty-printer starts a new line, +@racket[proc] is called with the new line's number (where the first +new line is numbered @racket[1]) and the just-finished line's length. +The destination-columns argument to @racket[proc] is always the total width of the destination printing area, or @racket['infinity] if pretty-printed values are not broken into lines. +If the @racket[#:newline?] argument was omitted or supplied with +a true value, @racket[proc] is also called after the last character of the +value has been printed, with @racket[#f] as the line number and with +the length of the last line. + The default @racket[proc] procedure prints a newline whenever the line number is not @racket[0] and the column count is not @racket['infinity], always returning @racket[0]. A custom diff --git a/pkgs/racket-doc/scribblings/reference/stx-taints.scrbl b/pkgs/racket-doc/scribblings/reference/stx-taints.scrbl index f9902bd4d4..76598c702b 100644 --- a/pkgs/racket-doc/scribblings/reference/stx-taints.scrbl +++ b/pkgs/racket-doc/scribblings/reference/stx-taints.scrbl @@ -88,7 +88,7 @@ the transformer's input. The @tech{rearm}ing process @item{If the result has no @racket['taint-mode] property value, but its datum is a pair, and if the syntax object corresponding to the @racket[car] of the pair is an identifier bound to - @racket[begin], @racket[module], or + @racket[begin], @racket[begin-for-syntax], or @racket[#%plain-module-begin], then dye packs are propagated as if the syntax object had the @racket['transparent] property value.} diff --git a/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl b/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl index 871da2b0fa..d559f77939 100644 --- a/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl +++ b/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl @@ -968,9 +968,26 @@ and different result procedures use distinct scopes. ((syntax?) ((or/c 'flip 'add 'remove)) . ->* . syntax?)]{ Produces a procedure that behaves like the result of -@racket[make-syntax-introducer], but using the @tech{scopes} of -@racket[ext-stx] that are not shared with @racket[base-stx], and with -a default action of @racket['remove]. +@racket[make-syntax-introducer], but using a set of @tech{scopes} from +@racket[ext-stx] and with a default action of @racket['add]. + +@itemlist[ + + @item{If the scopes of @racket[base-stx] are a subset of the scopes + of @racket[ext-stx], then the result of + @racket[make-syntax-delta-introducer] adds, removes, or flips + scopes that are in the set for @racket[ext-stx] and not in the + set for @racket[base-stx].} + + @item{If the scopes of @racket[base-stx] are not a subset of the + scopes of @racket[ext-stx], but if it has a binding, then the + set of scopes associated with the binding id subtracted from + the set of scopes for @racket[ext-stx], and the result of + @racket[make-syntax-delta-introducer] adds, removes, or flips + that difference.} + +] + A @racket[#f] value for @racket[base-stx] is equivalent to a syntax object with no @tech{scopes}. @@ -1012,8 +1029,9 @@ level as reported by @racket[syntax-local-phase-level].} @defproc[(syntax-local-module-required-identifiers [mod-path (or/c module-path? #f)] [phase-level (or/c exact-integer? #f #t)]) - (listof (cons/c (or/c exact-integer? #f) - (listof identifier?)))]{ + (or/c (listof (cons/c (or/c exact-integer? #f) + (listof identifier?))) + #f)]{ Can be called only while @racket[syntax-local-transforming-module-provides?] returns @@ -1025,7 +1043,9 @@ identifiers. Each list of identifiers includes all bindings imported @racket[mod-path], or all modules if @racket[mod-path] is @racket[#f]. The association list includes all identifiers imported with a @racket[phase-level] shift, or all shifts if -@racket[phase-level] is @racket[#t]. +@racket[phase-level] is @racket[#t]. If @racket[phase-level] is +not @racket[#t], the result can be @racket[#f] if no identifiers +are exported at that phase. When an identifier is renamed on import, the result association list includes the identifier by its internal name. Use diff --git a/pkgs/racket-doc/scribblings/reference/syntax.scrbl b/pkgs/racket-doc/scribblings/reference/syntax.scrbl index 2abffa68f1..c5033028f5 100644 --- a/pkgs/racket-doc/scribblings/reference/syntax.scrbl +++ b/pkgs/racket-doc/scribblings/reference/syntax.scrbl @@ -236,7 +236,8 @@ A @racket[module*] form in which the enclosing module's bindings are visible can define or import bindings that @tech{shadow} the enclosing module's bindings. The evaluation of a @racket[module] form does not evaluate the -expressions in the body of the module. Evaluation merely declares a +expressions in the body of the module (except sometimes for redeclarations; +see @secref["module-redeclare"]). Evaluation merely declares a module, whose full name depends both on @racket[id] or @racket[(current-module-declare-name)]. @@ -682,7 +683,7 @@ corresponds to the default @tech{module name resolver}. @racket[current-directory]). Regardless of the current platform, @racket[rel-string] is always parsed as a Unix-format relative path: @litchar{/} is the path delimiter (multiple adjacent @litchar{/}s are - treated as a single delimiter), @litchar{..} accesses the parent + not allowed), @litchar{..} accesses the parent directory, and @litchar{.} accesses the current directory. The path cannot be empty or contain a leading or trailing slash, path elements before than the last one cannot include a file suffix (i.e., a @@ -1215,7 +1216,8 @@ composable, and not extensible. Also, sub-form names like @racketidfont{for-syntax} and @racketidfont{lib} are recognized symbolically, instead of via bindings. Although not formalized in the grammar above, a @racketidfont{just-meta} form cannot appear within a -@racketidfont{just-meta} form. +@racketidfont{just-meta} form, but it can appear under @racketidfont{for-meta}, + @racketidfont{for-syntax}, @racketidfont{for-template}, or @racketidfont{for-label}. Each @racket[raw-require-spec] corresponds to the obvious @racket[_require-spec], but the @racketidfont{rename} sub-form has the diff --git a/pkgs/racket-test-core/tests/racket/optimize.rktl b/pkgs/racket-test-core/tests/racket/optimize.rktl index 47b50ee1d5..c27e1aa46b 100644 --- a/pkgs/racket-test-core/tests/racket/optimize.rktl +++ b/pkgs/racket-test-core/tests/racket/optimize.rktl @@ -904,6 +904,32 @@ )) +;; Check JIT handling of structure-reference sequencese +(parameterize ([current-namespace (make-base-namespace)] + [eval-jit-enabled #t]) + (eval '(module paper racket/base + (provide (all-defined-out)) + (struct paper (width height folds) #:transparent) + (define (fold-letter l) + (for/fold ([l l]) ([i (in-range 100)]) + (and (paper? l) + (struct-copy paper l [folds i])))) + (define (refine-letter l) + (for/fold ([l l]) ([i (in-range 100)]) + (and (paper? l) + (struct-copy paper l [width i])))))) + (eval '(require 'paper)) + (eval '(define letter (paper 8.5 11 0))) + (eval '(define formal-letter (chaperone-struct letter paper-height + (lambda (s v) + (unless (equal? v 11) + (error "wrong")) + v)))) + (test #t eval '(equal? (fold-letter letter) (paper 8.5 11 99))) + (test #t eval '(equal? (fold-letter formal-letter) (paper 8.5 11 99))) + (test #t eval '(equal? (refine-letter letter) (paper 99 11 0))) + (test #t eval '(equal? (refine-letter formal-letter) (paper 99 11 0)))) + (define (comp=? c1 c2 want-same?) (let ([s1 (open-output-bytes)] [s2 (open-output-bytes)]) diff --git a/pkgs/racket-test-core/tests/racket/pretty.rktl b/pkgs/racket-test-core/tests/racket/pretty.rktl index 327c4a0b58..e991e47b65 100644 --- a/pkgs/racket-test-core/tests/racket/pretty.rktl +++ b/pkgs/racket-test-core/tests/racket/pretty.rktl @@ -475,6 +475,42 @@ (test "#true" pretty-format #t) (test "#false" pretty-format #f)) +;; ---------------------------------------- +;; check that pretty-print follows the +;; #:newline? argument + +;; no #:newline? argument, tests the default +(let ([p (open-output-string)]) + (parameterize ([current-output-port p] + [pretty-print-columns 40]) + (pretty-print '(define (f xs) + (for/list ([x (in-list xs)]) + (+ x 1))))) + (test "'(define (f xs)\n (for/list\n ((x (in-list xs)))\n (+ x 1)))\n" + get-output-string p)) + +;; #:newline? #t, same as the default +(let ([p (open-output-string)]) + (parameterize ([current-output-port p] + [pretty-print-columns 40]) + (pretty-print '(define (f xs) + (for/list ([x (in-list xs)]) + (+ x 1))) + #:newline? #t)) + (test "'(define (f xs)\n (for/list\n ((x (in-list xs)))\n (+ x 1)))\n" + get-output-string p)) + +;; #:newline? #f +(let ([p (open-output-string)]) + (parameterize ([current-output-port p] + [pretty-print-columns 40]) + (pretty-print '(define (f xs) + (for/list ([x (in-list xs)]) + (+ x 1))) + #:newline? #f)) + (test "'(define (f xs)\n (for/list\n ((x (in-list xs)))\n (+ x 1)))" + get-output-string p)) + ;; ---------------------------------------- ;; check that an all-powerful inspector doesn't break the pretty printer internally diff --git a/pkgs/zo-lib/compiler/zo-marshal.rkt b/pkgs/zo-lib/compiler/zo-marshal.rkt index e969984570..13c2c65fa4 100644 --- a/pkgs/zo-lib/compiler/zo-marshal.rkt +++ b/pkgs/zo-lib/compiler/zo-marshal.rkt @@ -654,17 +654,17 @@ (if (function-shape-preserves-marks? constantness) 1 0))]))] [(struct-type-shape? constantness) (to-sym (arithmetic-shift (struct-type-shape-field-count constantness) - 4))] + 3))] [(constructor-shape? constantness) (to-sym (bitwise-ior 1 (arithmetic-shift (constructor-shape-arity constantness) - 4)))] + 3)))] [(predicate-shape? constantness) (to-sym 2)] [(accessor-shape? constantness) (to-sym (bitwise-ior 3 (arithmetic-shift (accessor-shape-field-count constantness) - 4)))] + 3)))] [(mutator-shape? constantness) (to-sym (bitwise-ior 4 (arithmetic-shift (mutator-shape-field-count constantness) - 4)))] + 3)))] [(struct-type-property-shape? constantness) (to-sym #:prefix "prop" (if (struct-type-property-shape-has-guard? constantness) @@ -1197,7 +1197,7 @@ (append (vector->list closure-map) (let* ([v (make-vector (ceiling - (/ (* BITS_PER_ARG (+ num-params (vector-length closure-map))) + (/ (* BITS_PER_ARG (+ num-all-params (vector-length closure-map))) BITS_PER_MZSHORT)))] [set-bit! (lambda (i bit) (let ([pos (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)]) diff --git a/pkgs/zo-lib/compiler/zo-parse.rkt b/pkgs/zo-lib/compiler/zo-parse.rkt index baae6869a8..62dc0d48e1 100644 --- a/pkgs/zo-lib/compiler/zo-parse.rkt +++ b/pkgs/zo-lib/compiler/zo-parse.rkt @@ -801,7 +801,7 @@ (define n (string->number (substring (symbol->string shape) 4))) (case n [(0 1) (make-struct-type-property-shape (= n 1))] - [(3) (make-property-predicate-shape)] + [(2) (make-property-predicate-shape)] [else (make-property-accessor-shape)])] [else ;; parse symbol as ":"-separated sequence of arities diff --git a/racket/collects/net/http-client.rkt b/racket/collects/net/http-client.rkt index 27abbb3aad..e965a6ff3d 100644 --- a/racket/collects/net/http-client.rkt +++ b/racket/collects/net/http-client.rkt @@ -291,6 +291,11 @@ (define abandon-p ssl-abndn-p) (values clt-ctx r:from r:to abandon-p)])) +(define (head? method-bss) + (or (equal? method-bss #"HEAD") + (equal? method-bss "HEAD") + (equal? method-bss 'HEAD))) + (define (http-conn-recv! hc #:method [method-bss #"GET"] #:content-decode [decodes '(gzip)] @@ -302,13 +307,9 @@ (regexp-member #rx#"^(?i:Connection: +close)$" headers))) (when close? (http-conn-abandon! hc)) - (define head? - (or (equal? method-bss #"HEAD") - (equal? method-bss "HEAD") - (equal? method-bss 'HEAD))) (define-values (raw-response-port wait-for-close?) (cond - [head? (values (open-input-bytes #"") #f)] + [(head? method-bss) (values (open-input-bytes #"") #f)] [(regexp-member #rx#"^(?i:Transfer-Encoding: +chunked)$" headers) (values (http-conn-response-port/chunked! hc #:close? #t) #t)] @@ -327,7 +328,7 @@ (values (http-conn-response-port/rest! hc) #t)])) (define decoded-response-port (cond - [head? raw-response-port] + [(head? method-bss) raw-response-port] [(and (memq 'gzip decodes) (regexp-member #rx#"^(?i:Content-Encoding: +gzip)$" headers) (not (eof-object? (peek-byte raw-response-port)))) @@ -377,13 +378,15 @@ #:data [data #f] #:content-decode [decodes '(gzip)]) (define hc (http-conn-open host-bs #:ssl? ssl? #:port port)) - (http-conn-sendrecv! hc url-bs - #:version version-bs - #:method method-bss - #:headers headers-bs - #:data data - #:content-decode decodes - #:close? #t)) + (begin0 (http-conn-sendrecv! hc url-bs + #:version version-bs + #:method method-bss + #:headers headers-bs + #:data data + #:content-decode decodes + #:close? #t) + (when (head? method-bss) + (http-conn-close! hc)))) (define data-procedure/c (-> (-> (or/c bytes? string?) void?) any)) diff --git a/racket/collects/openssl/mzssl.rkt b/racket/collects/openssl/mzssl.rkt index 32d36b54ee..ca3576e1db 100644 --- a/racket/collects/openssl/mzssl.rkt +++ b/racket/collects/openssl/mzssl.rkt @@ -266,7 +266,7 @@ TO DO: (define-ssl SSL_CTX_free (_fun _SSL_CTX* -> _void) #:wrap (deallocator)) -(define-ssl SSL_CTX_new (_fun _SSL_METHOD* -> _SSL_CTX*) +(define-ssl SSL_CTX_new (_fun _SSL_METHOD* -> _SSL_CTX*/null) #:wrap (allocator SSL_CTX_free)) (define-ssl SSL_CTX_callback_ctrl (_fun _SSL_CTX* _int diff --git a/racket/collects/racket/pretty.rkt b/racket/collects/racket/pretty.rkt index 786b75a108..850f509453 100644 --- a/racket/collects/racket/pretty.rkt +++ b/racket/collects/racket/pretty.rkt @@ -9,1633 +9,1628 @@ ;; require this module and evaluate: ;; (current-print pretty-print-handler) -(module pretty racket/base - (require racket/private/port - racket/flonum - racket/fixnum) +#lang racket/base +(require racket/private/port + racket/flonum + racket/fixnum) - (provide pretty-print - pretty-write - pretty-display - pretty-print-columns - pretty-print-depth - pretty-print-handler - pretty-print-size-hook - pretty-print-print-hook - pretty-print-pre-print-hook - pretty-print-post-print-hook - pretty-print-print-line - pretty-print-show-inexactness - pretty-print-exact-as-decimal - pretty-print-.-symbol-without-bars - pretty-print-abbreviate-read-macros - - pretty-print-style-table? - pretty-print-current-style-table - pretty-print-extend-style-table - pretty-print-remap-stylable - - pretty-format - pretty-printing - pretty-print-newline - make-tentative-pretty-print-output-port - tentative-pretty-print-port-transfer - tentative-pretty-print-port-cancel) +(provide pretty-print + pretty-write + pretty-display + pretty-print-columns + pretty-print-depth + pretty-print-handler + pretty-print-size-hook + pretty-print-print-hook + pretty-print-pre-print-hook + pretty-print-post-print-hook + pretty-print-print-line + pretty-print-show-inexactness + pretty-print-exact-as-decimal + pretty-print-.-symbol-without-bars + pretty-print-abbreviate-read-macros + + pretty-print-style-table? + pretty-print-current-style-table + pretty-print-extend-style-table + pretty-print-remap-stylable + + pretty-format + pretty-printing + pretty-print-newline + make-tentative-pretty-print-output-port + tentative-pretty-print-port-transfer + tentative-pretty-print-port-cancel) - (define-struct pretty-print-style-table (hash)) +(define-struct pretty-print-style-table (hash)) - (define pretty-print-extend-style-table - (lambda (table symbols like-symbols) - (let ([terr (lambda (kind which) - (raise-argument-error - 'pretty-print-extend-style-table - kind - which - table symbols like-symbols))]) - (unless (or (not table) (pretty-print-style-table? table)) - (terr "(or/c pretty-print-style-table? #f)" 0)) - (unless (and (list? symbols) - (andmap symbol? symbols)) - (terr "(listof symbol?)" 1)) - (unless (and (list? like-symbols) - (andmap symbol? like-symbols)) - (terr "(listof symbol?)" 1)) - (unless (= (length symbols) (length like-symbols)) - (raise-arguments-error - 'pretty-print-extend-style-table - "length of first list doesn't match the length of the second list" - "first list length" (length symbols) - "second list length" (length like-symbols) - "first list" symbols - "second list" like-symbols))) - (let ([ht (if table (pretty-print-style-table-hash table) (make-hasheq))] - [new-ht (make-hasheq)]) - (hash-for-each - ht - (lambda (key val) - (hash-set! new-ht key val))) - (for-each - (lambda (symbol like-symbol) - (let ((s (hash-ref ht - like-symbol - (lambda () #f)))) - (hash-set! new-ht symbol (or s like-symbol)))) - symbols like-symbols) - (make-pretty-print-style-table new-ht)))) +(define pretty-print-extend-style-table + (lambda (table symbols like-symbols) + (let ([terr (lambda (kind which) + (raise-argument-error + 'pretty-print-extend-style-table + kind + which + table symbols like-symbols))]) + (unless (or (not table) (pretty-print-style-table? table)) + (terr "(or/c pretty-print-style-table? #f)" 0)) + (unless (and (list? symbols) + (andmap symbol? symbols)) + (terr "(listof symbol?)" 1)) + (unless (and (list? like-symbols) + (andmap symbol? like-symbols)) + (terr "(listof symbol?)" 1)) + (unless (= (length symbols) (length like-symbols)) + (raise-arguments-error + 'pretty-print-extend-style-table + "length of first list doesn't match the length of the second list" + "first list length" (length symbols) + "second list length" (length like-symbols) + "first list" symbols + "second list" like-symbols))) + (let ([ht (if table (pretty-print-style-table-hash table) (make-hasheq))] + [new-ht (make-hasheq)]) + (hash-for-each + ht + (lambda (key val) + (hash-set! new-ht key val))) + (for-each + (lambda (symbol like-symbol) + (let ((s (hash-ref ht + like-symbol + (lambda () #f)))) + (hash-set! new-ht symbol (or s like-symbol)))) + symbols like-symbols) + (make-pretty-print-style-table new-ht)))) - (define pretty-print-abbreviate-read-macros (make-parameter #t)) +(define pretty-print-abbreviate-read-macros (make-parameter #t)) + +(define pretty-print-current-style-table + (make-parameter + (pretty-print-extend-style-table #f null null) + (lambda (s) + (unless (pretty-print-style-table? s) + (raise-argument-error + 'pretty-print-current-style-table + "pretty-print-style-table?" + s)) + s))) + +(define pretty-print-.-symbol-without-bars + (make-parameter #f (lambda (x) (and x #t)))) + +(define pretty-print-show-inexactness + (make-parameter #f + (lambda (x) (and x #t)))) + +(define pretty-print-exact-as-decimal + (make-parameter #f + (lambda (x) (and x #t)))) + +(define pretty-print-columns + (make-parameter 79 + (lambda (x) + (unless (or (eq? x 'infinity) + (integer? x)) + (raise-argument-error + 'pretty-print-columns + "(or/c integer? 'infinity)" + x)) + x))) + +(define pretty-print-depth + (make-parameter #f + (lambda (x) + (unless (or (not x) (number? x)) + (raise-argument-error + 'pretty-print-depth + "(or/c number? #f)" + x)) + x))) + +(define can-accept-n? + (lambda (n x) + (procedure-arity-includes? x n))) + +(define pretty-print-size-hook + (make-parameter (lambda (x display? port) #f) + (lambda (x) + (unless (can-accept-n? 3 x) + (raise-argument-error + 'pretty-print-size-hook + "(any/c any/c any/c . -> . any/c)" + x)) + x))) + +(define pretty-print-print-hook + (make-parameter void + (lambda (x) + (unless (can-accept-n? 3 x) + (raise-argument-error + 'pretty-print-print-hook + "(any/c any/c any/c . -> . any/c)" + x)) + x))) + +(define pretty-print-print-line + (make-parameter (lambda (line port offset width) + (when (and (number? width) + (not (eq? 0 line))) + (newline port)) + 0) + (lambda (x) + (unless (can-accept-n? 4 x) + (raise-argument-error + 'pretty-print-print-line + "(procedure-arity-includes/c 4)" + x)) + x))) + +(define pretty-print-pre-print-hook + (make-parameter void + (lambda (x) + (unless (can-accept-n? 2 x) + (raise-argument-error + 'pretty-print-pre-print-hook + "(any/c any/c . -> . any/c)" + x)) + x))) + +(define pretty-print-post-print-hook + (make-parameter void + (lambda (x) + (unless (can-accept-n? 2 x) + (raise-argument-error + 'pretty-print-post-print-hook + "(any/c any/c . -> . any/c)" + x)) + x))) + +(define pretty-printing + (make-parameter #f (lambda (x) (and x #t)))) + +(define pretty-print-remap-stylable + (make-parameter (λ (x) #f) + (λ (f) + (unless (can-accept-n? 1 f) + (raise-argument-error + 'pretty-print-remap-stylable + "(symbol? . -> . (or/c symbol? #f))" + f)) + (λ (x) + (let ([res (f x)]) + (unless (or (not res) (symbol? res)) + (raise-result-error + 'pretty-print-remap-stylable + "(or/c symbol? #f)" + res)) + res))))) + +(define make-pretty-print + (lambda (name display? as-qq?) + (letrec ([pretty-print + (lambda (obj [port (current-output-port)] [qq-depth 0] #:newline? [newline? #t]) + (unless (output-port? port) + (raise-argument-error name "output-port?" port)) + (unless (or (equal? qq-depth 0) + (equal? qq-depth 1)) + (raise-argument-error name "(or/c 0 1)" qq-depth)) + (unless (boolean? newline?) + (raise-argument-error name "boolean?" newline?)) + (let ([width (pretty-print-columns)] + [size-hook (pretty-print-size-hook)] + [print-hook (pretty-print-print-hook)] + [pre-hook (pretty-print-pre-print-hook)] + [post-hook (pretty-print-post-print-hook)]) + (generic-write obj display? #:newline? newline? + width + (make-printing-port port + pre-hook + post-hook + print-hook + (pretty-print-print-line)) + (print-graph) (print-struct) (print-hash-table) + (and (not display?) (print-vector-length)) (print-box) + (and (not display?) as-qq? (print-as-expression)) qq-depth + (pretty-print-depth) + (lambda (o display?) + (size-hook o display? port))) + (void)))]) + pretty-print))) + +(define pretty-print (make-pretty-print 'pretty-print #f #t)) +(define pretty-display (let ([pp (make-pretty-print 'pretty-display #t #f)]) + (lambda (v [o (current-output-port)] #:newline? [n? #t]) + (pp v o #:newline? n?)))) +(define pretty-write (let ([pp (make-pretty-print 'pretty-write #f #f)]) + (lambda (v [o (current-output-port)] #:newline? [n? #t]) + (pp v o #:newline? n?)))) + +(define-struct mark (str def) #:mutable) +(define-struct hide (val)) + +(define (make-tentative-output-port pport width esc) + (let* ([content null] + [special-ok? (port-writes-special? pport)] + ;; The null device counts for us: + [/dev/null + (let-values ([(line col pos) (port-next-location pport)]) + (relocate-output-port + (let ([p (open-output-nowhere special-ok?)]) + (port-count-lines! p) + p) + (or line 1) (or col 0) (or pos 1)))] + [first-line? #t] + [check-esc (lambda () + (let-values ([(l c p) (port-next-location /dev/null)]) + (when (or (c . > . width) + (not first-line?)) + (esc))))] + [p (make-output-port + 'tentative + always-evt + (lambda (s start end block? break?) + (write-bytes s /dev/null start end) + (check-esc) + (set! content (cons (subbytes s start end) content)) + (- end start)) + void + (and special-ok? + (lambda (special block break?) + (write-special special /dev/null) + (check-esc) + (set! content (cons (cons 'special special) content)) + #t)) + #f #f + (lambda () + (port-next-location /dev/null)))]) + (port-count-lines! /dev/null) + (port-count-lines! p) + (register-printing-port p + (make-print-port-info + (lambda () (reverse content)) + (box #t) + (lambda (v) + (set! content (cons (cons 'pre v) content))) + (lambda (v) + (set! content (cons (cons 'post v) content))) + (lambda (v len display?) + (display (make-string len #\.) /dev/null) + (set! content (cons (list* 'hooked v len display?) + content))) + (lambda (use-line? offset width) + (when (and (number? width) + (not first-line?)) + (newline p)) + (set! first-line? #f) + 0) + esc)))) + +(define (make-tentative-pretty-print-output-port pport width esc) + (let ([p (make-tentative-output-port pport width esc)]) + (port-write-handler p (port-write-handler pport)) + (port-display-handler p (port-display-handler pport)) + (port-print-handler p (port-print-handler pport)) + p)) + +(define (make-printing-port port pre-print post-print output-hooked print-line) + (let-values ([(line col pos) (port-next-location port)]) + (let* ([orig-counts? (and line col pos)] + [p (if orig-counts? + (relocate-output-port port line col pos #f) + (transplant-output-port port #f 1 #f))] + [line -1]) + (port-count-lines! p) + (register-printing-port p + (make-print-port-info + (lambda () null) + (box #t) + (lambda (v) + (pre-print v port)) + (lambda (v) + (post-print v port)) + (lambda (v len display?) + (output-hooked v display? p)) + (lambda (use-line? offset width) + (set! line (add1 line)) + (print-line (and use-line? line) p offset width)) + void))))) + +(struct printing-port (port info) + #:property prop:output-port 0) + +(define-struct print-port-info (get-content + def-box + pre-print + post-print + output-hooked + print-line + esc)) + +(define (register-printing-port p info) + (printing-port p info)) + +(define (register-printing-port-like p pport) + (printing-port p (printing-port-info pport))) + +(define (get pport selector) + (selector (printing-port-info pport))) + +(define (printing-port-pre-print pport) + (get pport print-port-info-pre-print)) +(define (printing-port-post-print pport) + (get pport print-port-info-post-print)) +(define (printing-port-def-box pport) + (get pport print-port-info-def-box)) +(define (printing-port-output-hooked pport) + (get pport print-port-info-output-hooked)) +(define (printing-port-print-line pport) + (get pport print-port-info-print-line)) +(define (printing-port-esc pport) + (get pport print-port-info-esc)) + +(define orig-display (port-display-handler (open-output-string))) +(define orig-write (port-write-handler (open-output-string))) + +(define (pretty-print-newline pport width) + (let-values ([(l col p) (port-next-location pport)]) + ((printing-port-print-line pport) #t (or col 0) width))) + +(define (tentative-pretty-print-port-transfer a-pport pport) + (let ([content ((get a-pport print-port-info-get-content))]) + (for-each (lambda (elem) + (if (bytes? elem) + (write-bytes elem pport) + (case (car elem) + [(special) (write-special (cdr elem) pport)] + [(pre) ((printing-port-pre-print pport) (cdr elem))] + [(post) ((printing-port-post-print pport) (cdr elem))] + [(hooked) ((printing-port-output-hooked pport) + (cadr elem) (caddr elem) (cdddr elem))]))) + content))) + +(define (tentative-pretty-print-port-cancel pport) + (set-box! (get pport print-port-info-def-box) #f)) + +(define (add-spaces n port) + (if (> n 0) + (if (> n 7) + (begin + (write-string " " port) + (add-spaces (- n 8) port)) + (write-string " " port 0 n)) + (void))) + +(define (prefab?! obj v) + (let ([d (prefab-struct-key obj)]) + (and d + (begin + (vector-set! v 0 d) + #t)))) + +(define-struct unquoted (val)) +(define struct-ellipses (string->uninterned-symbol "...")) + +(define (generic-write obj display? width pport + print-graph? print-struct? print-hash-table? print-vec-length? + print-box? print-as-qq? qq-depth + depth size-hook #:newline? newline?) + + (define pair-open (if (print-pair-curly-braces) "{" "(")) + (define pair-close (if (print-pair-curly-braces) "}" ")")) + (define mpair-open (if (print-mpair-curly-braces) "{" "(")) + (define mpair-close (if (print-mpair-curly-braces) "}" ")")) - (define pretty-print-current-style-table - (make-parameter - (pretty-print-extend-style-table #f null null) - (lambda (s) - (unless (pretty-print-style-table? s) - (raise-argument-error - 'pretty-print-current-style-table - "pretty-print-style-table?" - s)) - s))) + (define table (make-hasheq)) ; Hash table for looking for loops - (define pretty-print-.-symbol-without-bars - (make-parameter #f (lambda (x) (and x #t)))) + (define show-inexactness? (pretty-print-show-inexactness)) + (define exact-as-decimal? (pretty-print-exact-as-decimal)) - (define pretty-print-show-inexactness - (make-parameter #f - (lambda (x) (and x #t)))) - - (define pretty-print-exact-as-decimal - (make-parameter #f - (lambda (x) (and x #t)))) - - (define pretty-print-columns - (make-parameter 79 - (lambda (x) - (unless (or (eq? x 'infinity) - (integer? x)) - (raise-argument-error - 'pretty-print-columns - "(or/c integer? 'infinity)" - x)) - x))) - - (define pretty-print-depth - (make-parameter #f - (lambda (x) - (unless (or (not x) (number? x)) - (raise-argument-error - 'pretty-print-depth - "(or/c number? #f)" - x)) - x))) - - (define can-accept-n? - (lambda (n x) - (procedure-arity-includes? x n))) - - (define pretty-print-size-hook - (make-parameter (lambda (x display? port) #f) - (lambda (x) - (unless (can-accept-n? 3 x) - (raise-argument-error - 'pretty-print-size-hook - "(any/c any/c any/c . -> . any/c)" - x)) - x))) - - (define pretty-print-print-hook - (make-parameter void - (lambda (x) - (unless (can-accept-n? 3 x) - (raise-argument-error - 'pretty-print-print-hook - "(any/c any/c any/c . -> . any/c)" - x)) - x))) - - (define pretty-print-print-line - (make-parameter (lambda (line port offset width) - (when (and (number? width) - (not (eq? 0 line))) - (newline port)) - 0) - (lambda (x) - (unless (can-accept-n? 4 x) - (raise-argument-error - 'pretty-print-print-line - "(procedure-arity-includes/c 4)" - x)) - x))) - - (define pretty-print-pre-print-hook - (make-parameter void - (lambda (x) - (unless (can-accept-n? 2 x) - (raise-argument-error - 'pretty-print-pre-print-hook - "(any/c any/c . -> . any/c)" - x)) - x))) - - (define pretty-print-post-print-hook - (make-parameter void - (lambda (x) - (unless (can-accept-n? 2 x) - (raise-argument-error - 'pretty-print-post-print-hook - "(any/c any/c . -> . any/c)" - x)) - x))) - - (define pretty-printing - (make-parameter #f (lambda (x) (and x #t)))) + (define long-bools? (print-boolean-long-form)) - (define pretty-print-remap-stylable - (make-parameter (λ (x) #f) - (λ (f) - (unless (can-accept-n? 1 f) - (raise-argument-error - 'pretty-print-remap-stylable - "(symbol? . -> . (or/c symbol? #f))" - f)) - (λ (x) - (let ([res (f x)]) - (unless (or (not res) (symbol? res)) - (raise-result-error - 'pretty-print-remap-stylable - "(or/c symbol? #f)" - res)) - res))))) + (define-syntax-rule (mkvector->repeatless-list name v-length v-ref equal-op? ->list) + (define name + (if print-vec-length? + (lambda (v) + (let ([len (v-length v)]) + (if (zero? len) + null + (let ([last (v-ref v (sub1 len))]) + (let loop ([i (- len 2)]) + (if (i . < . 0) + (list last) + (let ([e (v-ref v i)]) + (if (equal-op? e last) + (loop (sub1 i)) + (let loop ([i (sub1 i)][r (list e last)]) + (if (i . < . 0) + r + (loop (sub1 i) (cons (v-ref v i) r)))))))))))) + ->list))) - (define make-pretty-print - (lambda (name display? as-qq?) - (letrec ([pretty-print - (case-lambda - [(obj port qq-depth) - (unless (output-port? port) - (raise-argument-error name "output-port?" port)) - (unless (or (equal? qq-depth 0) - (equal? qq-depth 1)) - (raise-argument-error name "(or/c 0 1)" qq-depth)) - (let ([width (pretty-print-columns)] - [size-hook (pretty-print-size-hook)] - [print-hook (pretty-print-print-hook)] - [pre-hook (pretty-print-pre-print-hook)] - [post-hook (pretty-print-post-print-hook)]) - (generic-write obj display? - width - (make-printing-port port - pre-hook - post-hook - print-hook - (pretty-print-print-line)) - (print-graph) (print-struct) (print-hash-table) - (and (not display?) (print-vector-length)) (print-box) - (and (not display?) as-qq? (print-as-expression)) qq-depth - (pretty-print-depth) - (lambda (o display?) - (size-hook o display? port))) - (void))] - [(obj port) (pretty-print obj port 0)] - [(obj) (pretty-print obj (current-output-port))])]) - pretty-print))) + (mkvector->repeatless-list vector->repeatless-list vector-length vector-ref eq? vector->list) + (mkvector->repeatless-list flvector->repeatless-list flvector-length flvector-ref equal? + (lambda (v) (for/list ([x (in-flvector v)]) x))) + (mkvector->repeatless-list fxvector->repeatless-list fxvector-length fxvector-ref eq? + (lambda (v) (for/list ([x (in-fxvector v)]) x))) - (define pretty-print (make-pretty-print 'pretty-print #f #t)) - (define pretty-display (let ([pp (make-pretty-print 'pretty-display #t #f)]) - (case-lambda - [(v) (pp v)] - [(v o) (pp v o)]))) - (define pretty-write (let ([pp (make-pretty-print 'pretty-write #f #f)]) - (case-lambda - [(v) (pp v)] - [(v o) (pp v o)]))) + (define (extract-sub-objects obj pport) + (let ([p (open-output-nowhere 'null (port-writes-special? pport))] + [l null]) + (let ([record (lambda (o p) (set! l (cons o l)))]) + (port-write-handler p record) + (port-display-handler p record) + (port-print-handler p record)) + (parameterize ([pretty-printing #f]) + ((custom-write-accessor obj) obj p #f)) + l)) - (define-struct mark (str def) #:mutable) - (define-struct hide (val)) - - (define (make-tentative-output-port pport width esc) - (let* ([content null] - [special-ok? (port-writes-special? pport)] - ;; The null device counts for us: - [/dev/null - (let-values ([(line col pos) (port-next-location pport)]) - (relocate-output-port - (let ([p (open-output-nowhere special-ok?)]) - (port-count-lines! p) - p) - (or line 1) (or col 0) (or pos 1)))] - [first-line? #t] - [check-esc (lambda () - (let-values ([(l c p) (port-next-location /dev/null)]) - (when (or (c . > . width) - (not first-line?)) - (esc))))] - [p (make-output-port - 'tentative - always-evt - (lambda (s start end block? break?) - (write-bytes s /dev/null start end) - (check-esc) - (set! content (cons (subbytes s start end) content)) - (- end start)) - void - (and special-ok? - (lambda (special block break?) - (write-special special /dev/null) - (check-esc) - (set! content (cons (cons 'special special) content)) - #t)) - #f #f - (lambda () - (port-next-location /dev/null)))]) - (port-count-lines! /dev/null) - (port-count-lines! p) - (register-printing-port p - (make-print-port-info - (lambda () (reverse content)) - (box #t) - (lambda (v) - (set! content (cons (cons 'pre v) content))) - (lambda (v) - (set! content (cons (cons 'post v) content))) - (lambda (v len display?) - (display (make-string len #\.) /dev/null) - (set! content (cons (list* 'hooked v len display?) - content))) - (lambda (use-line? offset width) - (when (and (number? width) - (not first-line?)) - (newline p)) - (set! first-line? #f) - 0) - esc)))) - - (define (make-tentative-pretty-print-output-port pport width esc) - (let ([p (make-tentative-output-port pport width esc)]) - (port-write-handler p (port-write-handler pport)) - (port-display-handler p (port-display-handler pport)) - (port-print-handler p (port-print-handler pport)) - p)) - - (define (make-printing-port port pre-print post-print output-hooked print-line) - (let-values ([(line col pos) (port-next-location port)]) - (let* ([orig-counts? (and line col pos)] - [p (if orig-counts? - (relocate-output-port port line col pos #f) - (transplant-output-port port #f 1 #f))] - [line -1]) - (port-count-lines! p) - (register-printing-port p - (make-print-port-info - (lambda () null) - (box #t) - (lambda (v) - (pre-print v port)) - (lambda (v) - (post-print v port)) - (lambda (v len display?) - (output-hooked v display? p)) - (lambda (use-line? offset width) - (set! line (add1 line)) - (print-line (and use-line? line) p offset width)) - void))))) - - (struct printing-port (port info) - #:property prop:output-port 0) - - (define-struct print-port-info (get-content - def-box - pre-print - post-print - output-hooked - print-line - esc)) - - (define (register-printing-port p info) - (printing-port p info)) - - (define (register-printing-port-like p pport) - (printing-port p (printing-port-info pport))) - - (define (get pport selector) - (selector (printing-port-info pport))) - - (define (printing-port-pre-print pport) - (get pport print-port-info-pre-print)) - (define (printing-port-post-print pport) - (get pport print-port-info-post-print)) - (define (printing-port-def-box pport) - (get pport print-port-info-def-box)) - (define (printing-port-output-hooked pport) - (get pport print-port-info-output-hooked)) - (define (printing-port-print-line pport) - (get pport print-port-info-print-line)) - (define (printing-port-esc pport) - (get pport print-port-info-esc)) - - (define orig-display (port-display-handler (open-output-string))) - (define orig-write (port-write-handler (open-output-string))) - - (define (pretty-print-newline pport width) - (let-values ([(l col p) (port-next-location pport)]) - ((printing-port-print-line pport) #t (or col 0) width))) - - (define (tentative-pretty-print-port-transfer a-pport pport) - (let ([content ((get a-pport print-port-info-get-content))]) - (for-each (lambda (elem) - (if (bytes? elem) - (write-bytes elem pport) - (case (car elem) - [(special) (write-special (cdr elem) pport)] - [(pre) ((printing-port-pre-print pport) (cdr elem))] - [(post) ((printing-port-post-print pport) (cdr elem))] - [(hooked) ((printing-port-output-hooked pport) - (cadr elem) (caddr elem) (cdddr elem))]))) - content))) - - (define (tentative-pretty-print-port-cancel pport) - (set-box! (get pport print-port-info-def-box) #f)) - - (define (add-spaces n port) - (if (> n 0) - (if (> n 7) - (begin - (write-string " " port) - (add-spaces (- n 8) port)) - (write-string " " port 0 n)) - (void))) - - (define (prefab?! obj v) - (let ([d (prefab-struct-key obj)]) - (and d - (begin - (vector-set! v 0 d) - #t)))) - - (define-struct unquoted (val)) - (define struct-ellipses (string->uninterned-symbol "...")) - - (define (generic-write obj display? width pport - print-graph? print-struct? print-hash-table? print-vec-length? - print-box? print-as-qq? qq-depth - depth size-hook) - - (define pair-open (if (print-pair-curly-braces) "{" "(")) - (define pair-close (if (print-pair-curly-braces) "}" ")")) - (define mpair-open (if (print-mpair-curly-braces) "{" "(")) - (define mpair-close (if (print-mpair-curly-braces) "}" ")")) - - (define table (make-hasheq)) ; Hash table for looking for loops - - (define show-inexactness? (pretty-print-show-inexactness)) - (define exact-as-decimal? (pretty-print-exact-as-decimal)) - - (define long-bools? (print-boolean-long-form)) - - (define-syntax-rule (mkvector->repeatless-list name v-length v-ref equal-op? ->list) - (define name - (if print-vec-length? - (lambda (v) - (let ([len (v-length v)]) - (if (zero? len) - null - (let ([last (v-ref v (sub1 len))]) - (let loop ([i (- len 2)]) - (if (i . < . 0) - (list last) - (let ([e (v-ref v i)]) - (if (equal-op? e last) - (loop (sub1 i)) - (let loop ([i (sub1 i)][r (list e last)]) - (if (i . < . 0) - r - (loop (sub1 i) (cons (v-ref v i) r)))))))))))) - ->list))) - - (mkvector->repeatless-list vector->repeatless-list vector-length vector-ref eq? vector->list) - (mkvector->repeatless-list flvector->repeatless-list flvector-length flvector-ref equal? - (lambda (v) (for/list ([x (in-flvector v)]) x))) - (mkvector->repeatless-list fxvector->repeatless-list fxvector-length fxvector-ref eq? - (lambda (v) (for/list ([x (in-fxvector v)]) x))) - - (define (extract-sub-objects obj pport) - (let ([p (open-output-nowhere 'null (port-writes-special? pport))] - [l null]) - (let ([record (lambda (o p) (set! l (cons o l)))]) - (port-write-handler p record) - (port-display-handler p record) - (port-print-handler p record)) - (parameterize ([pretty-printing #f]) - ((custom-write-accessor obj) obj p #f)) - l)) - - (define found-cycle - (or print-graph? - (let loop ([obj obj]) - (and (or (vector? obj) - (pair? obj) - (mpair? obj) - (and (box? obj) - print-box?) - (and (custom-write? obj) - (not (struct-type? obj))) - (and (struct? obj) print-struct?) - (and (hash? obj) print-hash-table?)) - (or (hash-ref table obj #f) - (begin - (hash-set! table obj #t) - (let ([cycle - (cond - [(vector? obj) - (let ([len (vector-length obj)]) - (let vloop ([i 0]) - (if (= i len) - #f - (or (loop (vector-ref obj i)) - (vloop (add1 i))))))] - [(pair? obj) - (or (loop (car obj)) - (loop (cdr obj)))] - [(mpair? obj) - (or (loop (mcar obj)) - (loop (mcdr obj)))] - [(and (box? obj) print-box?) (loop (unbox obj))] - [(and (custom-write? obj) - (not (struct-type? obj))) - (loop (extract-sub-objects obj pport))] - [(struct? obj) - (ormap loop - (vector->list (struct->vector obj)))] - [(hash? obj) - (for/or ([(k v) (in-hash obj)]) - (or (loop v) (loop k)))])]) - (hash-remove! table obj) - cycle))))))) - - (define __dummy__ - (when found-cycle - (let loop ([obj obj]) - (if (or (vector? obj) - (pair? obj) - (mpair? obj) - (and (box? obj) + (define found-cycle + (or print-graph? + (let loop ([obj obj]) + (and (or (vector? obj) + (pair? obj) + (mpair? obj) + (and (box? obj) print-box?) - (and (custom-write? obj) - (not (struct-type? obj))) - (and (struct? obj) print-struct?) - (and (hash? obj) print-hash-table?)) - ;; A little confusing: use #t for not-found - (let ([p (hash-ref table obj #t)]) - (when (not (mark? p)) - (if p - (begin - (hash-set! table obj #f) - (cond - [(vector? obj) - (let ([len (vector-length obj)]) - (let vloop ([i 0]) - (unless (= i len) - (loop (vector-ref obj i)) - (vloop (add1 i)))))] - [(pair? obj) - (loop (car obj)) - (loop (cdr obj))] - [(mpair? obj) - (loop (mcar obj)) - (loop (mcdr obj))] - [(and (box? obj) print-box?) (loop (unbox obj))] - [(and (custom-write? obj) - (not (struct-type? obj))) - (loop (extract-sub-objects obj pport))] - [(struct? obj) - (for-each loop - (vector->list (struct->vector obj)))] - [(hash? obj) - (hash-for-each - obj - (lambda (k v) - (loop k) - (loop v)))])) - (begin - (hash-set! table obj - (make-mark #f (box #f))))))) - (void))))) + (and (custom-write? obj) + (not (struct-type? obj))) + (and (struct? obj) print-struct?) + (and (hash? obj) print-hash-table?)) + (or (hash-ref table obj #f) + (begin + (hash-set! table obj #t) + (let ([cycle + (cond + [(vector? obj) + (let ([len (vector-length obj)]) + (let vloop ([i 0]) + (if (= i len) + #f + (or (loop (vector-ref obj i)) + (vloop (add1 i))))))] + [(pair? obj) + (or (loop (car obj)) + (loop (cdr obj)))] + [(mpair? obj) + (or (loop (mcar obj)) + (loop (mcdr obj)))] + [(and (box? obj) print-box?) (loop (unbox obj))] + [(and (custom-write? obj) + (not (struct-type? obj))) + (loop (extract-sub-objects obj pport))] + [(struct? obj) + (ormap loop + (vector->list (struct->vector obj)))] + [(hash? obj) + (for/or ([(k v) (in-hash obj)]) + (or (loop v) (loop k)))])]) + (hash-remove! table obj) + cycle))))))) - (define escapes-table - (let* ([table (make-hasheq)] - [local-compound (and print-as-qq? - (make-hasheq))] - [is-compound! (lambda (obj) - (hash-set! local-compound obj #t))] - [escapes! (lambda (obj) - (hash-set! table obj #t) - #t)] - [orf (lambda (a b) (or a b))]) - (when print-as-qq? - (let loop ([obj obj]) - (cond - [(hash-ref table obj #f) - ;; already decided that it escapes - #t] - [(and local-compound - (hash-ref local-compound obj #f)) - ;; either still deciding (so assume #f) or - ;; already decided that no escape is needed - #f] - [else - (cond - [(vector? obj) - (is-compound! obj) - (let ([len (vector-length obj)]) - (let vloop ([esc? #f][i 0]) - (if (= i len) - (and esc? - (escapes! obj)) - (vloop (or (loop (vector-ref obj i)) esc?) - (add1 i)))))] - [(flvector? obj) - (is-compound! obj) - ;; always unquoted: - #t] - [(fxvector? obj) - (is-compound! obj) - ;; always unquoted: - #t] - [(pair? obj) - (is-compound! obj) - (and (orf (loop (car obj)) - (loop (cdr obj))) - (escapes! obj))] - [(mpair? obj) - (is-compound! obj) - (loop (mcar obj)) - (loop (mcdr obj)) - ;; always unquoted: - #t] - [(and (box? obj) print-box?) - (is-compound! obj) - (and (loop (unbox obj)) - (escapes! obj))] - [(and (custom-write? obj) - (not (struct-type? obj))) - (is-compound! obj) - (let ([kind (if (custom-print-quotable? obj) - (custom-print-quotable-accessor obj) - 'self)]) - (and (or (and (loop (extract-sub-objects obj pport)) - (not (memq kind '(self always)))) - (memq kind '(never))) - (escapes! obj)))] - [(struct? obj) - (is-compound! obj) - (and (or (loop (struct->vector obj)) - (not (prefab-struct-key obj))) - (escapes! obj))] - [(hash? obj) - (is-compound! obj) - (and (for/fold ([esc? #f]) ([(k v) (in-hash obj)]) - (or (orf (loop v) - (loop k)) - esc?)) - (escapes! obj))] - [else #f])]))) - table)) - - (define cycle-counter 0) - - (define found (if found-cycle - table - #f)) - - (define dsub1 (lambda (d) - (if d - (sub1 d) - #f))) - - (define (pre-print pport obj) - ((printing-port-pre-print pport) obj)) - (define (post-print pport obj) - ((printing-port-post-print pport) - obj)) - (define (output-hooked pport obj len display?) - ((printing-port-output-hooked pport) - obj len display?)) - - (define expr-found - (lambda (pport ref) - (let ([n cycle-counter]) - (set! cycle-counter (add1 cycle-counter)) - (set-mark-str! ref - (string-append "#" - (number->string n) - "#")) - (set-mark-def! ref (printing-port-def-box pport)) - (display (string-append "#" - (number->string n) - "=") - pport)))) - - (define check-expr-found - (lambda (obj pport check? c-k d-k n-k) - (let ([ref (and check? - found - (hash-ref found obj #f))]) - (if (and ref (unbox (mark-def ref))) - (if c-k - (c-k (mark-str ref)) - (display (mark-str ref) pport)) - (if (and ref d-k) - (d-k) - (begin - (when ref - (expr-found pport ref)) - (n-k))))))) - - (define (write-custom recur obj pport depth display? width qd multi-line?) - (let-values ([(l c p) (port-next-location pport)]) - (let ([p (relocate-output-port pport l c p)]) - (port-count-lines! p) - (let ([writer (lambda (v port) - (recur port v (dsub1 depth) #f #f))] - [displayer (lambda (v port) - (recur port v (dsub1 depth) #t #f))] - [printer (case-lambda - [(v port) (recur port v (dsub1 depth) #f qd)] - [(v port qd) (recur port v (dsub1 depth) #f qd)])]) - (port-write-handler p writer) - (port-display-handler p displayer) - (port-print-handler p printer)) - (let ([p (register-printing-port-like p pport)]) - (parameterize ([pretty-printing multi-line?] - [pretty-print-columns (or width 'infinity)]) - ((custom-write-accessor obj) obj p (or qd (not display?)))))))) - - ;; ------------------------------------------------------------ - - (define (convert-pair obj) - (cond - [(list? obj) (cons (make-unquoted 'list) - ;; reconstruct first pair in case it - ;; starts a cycle: - (cons (car obj) (cdr obj)))] - [(and (pair? (cdr obj)) - (not (and found - (hash-ref found (cdr obj) #f)))) - (cons (make-unquoted 'list*) - (cons - (car obj) - (let loop ([obj (cdr obj)]) - (cond - [(and found (hash-ref found obj #f)) (list obj)] - [(pair? obj) (cons (car obj) (loop (cdr obj)))] - [else (list obj)]))))] - [else (list (make-unquoted 'cons) (car obj) (cdr obj))])) - - (define (convert-hash obj expr?) - (let ([l (hash-map obj (lambda (k v) - (if expr? - (list k v) - (cons k (make-hide v)))))]) - (if expr? - (cons (make-unquoted - (if (hash-eq? obj) - 'hasheq - (if (hash-eqv? obj) - 'hasheqv - 'hash))) - (apply append l)) - l))) - - ;; ------------------------------------------------------------ - ;; wr: write on a single line - (define (wr* pport obj depth display? qd) - - (define (out str) - (write-string str pport)) - - (define (wr obj depth qd) - (wr* pport obj depth display? qd)) - - (define (wr-expr expr depth pair? car cdr open close qd) - (if (and (read-macro? expr pair? car cdr qd) - (equal? open "(")) - (begin - (out (read-macro-prefix expr car)) - (wr (read-macro-body expr car cdr) depth qd)) - (wr-lst expr #t depth pair? car cdr open close qd))) - - (define (wr-lst l check? depth pair? car cdr open close qd) - (if (pair? l) - (if (and depth (zero? depth)) - (begin - (out open) - (out "...") - (out close)) - (begin - (out open) - (wr (car l) (dsub1 depth) qd) - (let loop ([l (cdr l)]) - (check-expr-found - l pport (and check? (pair? l)) - (lambda (s) (out " . ") (out s) (out close)) - (lambda () - (out " . ") - (check-expr-found ;; will find it! - l pport #t - #f #f - (lambda () - (wr-lst l check? (dsub1 depth) pair? car cdr open close qd))) - (out close)) - (lambda () - (cond - [(pair? l) - (if (and (eq? (do-remap (car l)) 'unquote) - (not (equal? qd 1)) - (pair? (cdr l)) - (null? (cdr (cdr l)))) - (begin - (out " . ,") - (wr (car (cdr l)) (dsub1 depth) qd) - (out close)) - (begin - (out " ") - (wr (car l) (dsub1 depth) qd) - (loop (cdr l))))] - [(null? l) (out close)] - [else - (out " . ") - (wr l (dsub1 depth) qd) - (out close)])))))) - (begin - (out open) - (out close)))) - - (unless (hide? obj) - (pre-print pport obj)) - (if (and depth - (negative? depth) - (not (hide? obj))) - (out "...") - - (cond - [(size-hook obj display?) - => (lambda (len) - (output-hooked pport obj len display?))] - - [(pair? obj) - (check-expr-found - obj pport #t - #f #f - (lambda () - (let* ([qd (to-quoted out qd obj)] - [pair (if (and qd (zero? qd)) - (convert-pair obj) - obj)]) - (wr-expr pair depth pair? car cdr pair-open pair-close qd))))] - [(mpair? obj) - (check-expr-found - obj pport #t - #f #f - (lambda () - (if (and qd (zero? qd)) - (wr-expr (list (make-unquoted 'mcons) (mcar obj) (mcdr obj)) - depth pair? car cdr pair-open pair-close qd) - (wr-expr obj depth mpair? mcar mcdr mpair-open mpair-close qd))))] - [(null? obj) - (let ([qd (to-quoted out qd obj)]) - (wr-lst obj #f depth pair? car cdr "(" ")" qd))] - [(vector? obj) - (check-expr-found - obj pport #t - #f #f - (lambda () - (let ([qd (to-quoted out qd obj)] - [vecl (vector->repeatless-list obj)]) - (if (and qd (zero? qd)) - (wr-lst (cons (make-unquoted 'vector) vecl) - #f depth pair? car cdr "(" ")" qd) - (begin - (out "#") - (when print-vec-length? - (out (number->string (vector-length obj)))) - (wr-lst vecl #f depth pair? car cdr "(" ")" qd))))))] - [(flvector? obj) - (check-expr-found - obj pport #t - #f #f - (lambda () - (let ([vecl (flvector->repeatless-list obj)]) - (if (and qd (zero? qd)) - (wr-lst (cons (make-unquoted 'flvector) vecl) - #f depth pair? car cdr "(" ")" qd) - (begin - (out "#fl") - (when print-vec-length? - (out (number->string (flvector-length obj)))) - (wr-lst vecl #f depth pair? car cdr "(" ")" qd))))))] - [(fxvector? obj) - (check-expr-found - obj pport #t - #f #f - (lambda () - (let ([vecl (fxvector->repeatless-list obj)]) - (if (and qd (zero? qd)) - (wr-lst (cons (make-unquoted 'fxvector) vecl) - #f depth pair? car cdr "(" ")" qd) - (begin - (out "#fx") - (when print-vec-length? - (out (number->string (fxvector-length obj)))) - (wr-lst vecl #f depth pair? car cdr "(" ")" qd))))))] - [(and (box? obj) - print-box?) - (check-expr-found - obj pport #t - #f #f - (lambda () - (let ([qd (to-quoted out qd obj)]) - (if (and qd (zero? qd)) - (wr-lst (list (make-unquoted 'box) (unbox obj)) - #f depth pair? car cdr "(" ")" qd) - (begin - (out "#&") - (wr (unbox obj) (dsub1 depth) qd))))))] - [(and (custom-write? obj) - (not (struct-type? obj))) - (check-expr-found - obj pport #t - #f #f - (lambda () - (parameterize ([pretty-print-columns 'infinity]) - (let ([qd (let ([kind (if (custom-print-quotable? obj) - (custom-print-quotable-accessor obj) - 'self)]) - (if (memq kind '(self never)) - qd - (to-quoted out qd obj)))]) - (write-custom wr* obj pport depth display? width qd #f)))))] - [(hide? obj) - (wr* pport (hide-val obj) depth display? qd)] - [(unquoted? obj) - (orig-write (unquoted-val obj) pport)] - [(struct? obj) - (if (and print-struct? - (not (and depth - (zero? depth)))) - (check-expr-found - obj pport #t - #f #f - (lambda () - (let* ([v (struct->vector obj struct-ellipses)] - [pf? (prefab?! obj v)]) - (let ([qd (if pf? - (to-quoted out qd obj) - qd)]) - (when (or (not qd) (positive? qd)) - (out "#") - (when pf? (out "s"))) - (wr-lst (let ([l (vector->list v)]) - (if (and qd (zero? qd)) - (cons (make-unquoted (object-name obj)) - (cdr l)) - l)) - #f (dsub1 depth) pair? car cdr "(" ")" - qd))))) - (parameterize ([print-struct #f]) - ((if display? orig-display orig-write) obj pport)))] - [(hash? obj) - (if (and print-hash-table? - (not (and depth - (zero? depth)))) - (check-expr-found - obj pport #t - #f #f - (lambda () - (let* ([qd (to-quoted out qd obj)] - [expr? (and qd (zero? qd))]) - (unless expr? - (out (if (hash-eq? obj) - "#hasheq" - (if (hash-eqv? obj) - "#hasheqv" - "#hash")))) - (wr-lst (convert-hash obj expr?) - #f depth - pair? car cdr "(" ")" qd)))) - (parameterize ([print-hash-table #f]) - ((if display? orig-display orig-write) obj pport)))] - [(boolean? obj) - (out (if long-bools? - (if obj "#true" "#false") - (if obj "#t" "#f")))] - [(number? obj) - (when (and show-inexactness? - (inexact? obj)) - (out "#i")) - (out ((if exact-as-decimal? - number->decimal-string - number->string) - obj))] - [(and (pretty-print-.-symbol-without-bars) - (eq? obj '|.|)) - (out ".")] - [(and qd (or (symbol? obj) - (keyword? obj))) - (unless (eq? obj struct-ellipses) - (to-quoted out qd obj)) - (orig-write obj pport)] - [else - ((if display? orig-display orig-write) obj pport)])) - (unless (hide? obj) - (post-print pport obj))) - - ;; ------------------------------------------------------------ - ;; pp: write on (potentially) multiple lines - (define (pp* pport obj depth display? qd) - - (define (pp obj depth) - (pp* pport obj depth display? qd)) - - (define (out str) - (write-string str pport)) - - (define (spaces n) - (add-spaces n pport)) - - (define (ccol) - (let-values ([(l col p) (port-next-location pport)]) - col)) - - (define (indent to) - (let ([col (ccol)]) - (if (< to col) - (begin - (let ([col ((printing-port-print-line pport) #t col width)]) - (spaces (- to col)))) - (spaces (max 0 (- to col)))))) - - (define (pr obj extra pp-pair depth qd) - ;; may have to split on multiple lines - (let* ([obj (if (hide? obj) (hide-val obj) obj)] - [can-multi (and width - (not (size-hook obj display?)) - (or (pair? obj) - (mpair? obj) - (vector? obj) - (flvector? obj) - (fxvector? obj) - (and (box? obj) print-box?) - (and (custom-write? obj) - (not (struct-type? obj))) - (and (struct? obj) print-struct?) - (and (hash? obj) print-hash-table?)))] - [graph-ref (if can-multi - (and found (hash-ref found obj #f)) - #f)] - [old-counter cycle-counter]) - (if (and can-multi - (or (not graph-ref) - (not (unbox (mark-def graph-ref))))) - ;; It might be possible to split obj across lines. - ;; Try writing the obj, but accumulate the info that goes out - ;; into a-pport - (let ([a-pport - (let/ec esc - (letrec ([a-pport (make-tentative-output-port - pport - (- width extra) - (lambda () (esc a-pport)))]) - ;; Here's the attempt to write on one line: - (wr* a-pport obj depth display? qd) - a-pport))]) - (let-values ([(l c p) (port-next-location a-pport)]) - (if (<= c (- width extra)) - ;; All can be printed on one line, so just dump the - ;; accumulated text - (tentative-pretty-print-port-transfer a-pport pport) - ;; Doesn't fit on one line, so start over - (begin - (tentative-pretty-print-port-cancel a-pport) - (set! cycle-counter old-counter) - (when graph-ref - (expr-found pport graph-ref)) - (pre-print pport obj) - (cond - [(pair? obj) - (let* ([qd (to-quoted out qd obj)] - [pair (if (and qd (zero? qd)) - (convert-pair obj) - obj)]) - (pp-pair pair extra depth - pair? car cdr pair-open pair-close - qd))] - [(mpair? obj) - (if (and qd (zero? qd)) - (pp-pair (list (make-unquoted 'mcons) (mcar obj) (mcdr obj)) - extra depth - pair? car cdr pair-open pair-close - qd) - (pp-pair obj extra depth - mpair? mcar mcdr mpair-open mpair-close - qd))] - [(vector? obj) - (let ([qd (to-quoted out qd obj)] - [vecl (vector->repeatless-list obj)]) - (if (and qd (zero? qd)) - (pp-pair (cons (make-unquoted 'vector) vecl) - extra depth - pair? car cdr pair-open pair-close - qd) - (begin - (out "#") - (when print-vec-length? - (out (number->string (vector-length obj)))) - (pp-list vecl extra pp-expr #f depth - pair? car cdr pair-open pair-close - qd))))] - [(flvector? obj) - (let ([vecl (flvector->repeatless-list obj)]) - (if (and qd (zero? qd)) - (pp-pair (cons (make-unquoted 'flvector) vecl) - extra depth - pair? car cdr pair-open pair-close - qd) - (begin - (out "#fl") - (when print-vec-length? - (out (number->string (flvector-length obj)))) - (pp-list vecl extra pp-expr #f depth - pair? car cdr pair-open pair-close - qd))))] - [(fxvector? obj) - (let ([vecl (fxvector->repeatless-list obj)]) - (if (and qd (zero? qd)) - (pp-pair (cons (make-unquoted 'fxvector) vecl) - extra depth - pair? car cdr pair-open pair-close - qd) - (begin - (out "#fx") - (when print-vec-length? - (out (number->string (fxvector-length obj)))) - (pp-list vecl extra pp-expr #f depth - pair? car cdr pair-open pair-close - qd))))] - [(and (custom-write? obj) - (not (struct-type? obj))) - (let ([qd (let ([kind (if (custom-print-quotable? obj) - (custom-print-quotable-accessor obj) - 'self)]) - (if (memq kind '(self never)) - qd - (to-quoted out qd obj)))]) - (write-custom pp* obj pport depth display? width qd #t))] - [(struct? obj) ; print-struct is on if we got here - (let* ([v (struct->vector obj struct-ellipses)] - [pf? (prefab?! obj v)]) - (let ([qd (if pf? - (to-quoted out qd obj) - qd)]) - (when (or (not qd) (positive? qd)) - (out "#") - (when pf? (out "s"))) - (pp-list (let ([l (vector->list v)]) - (if (and qd (zero? qd)) - (cons (make-unquoted (object-name obj)) - (cdr l)) - l)) - extra pp-expr #f depth - pair? car cdr pair-open pair-close - qd)))] - [(hash? obj) - (let* ([qd (to-quoted out qd obj)] - [expr? (and qd (zero? qd))]) - (unless expr? - (out (if (hash-eq? obj) - "#hasheq" - (if (hash-eqv? obj) - "#hasheqv" - "#hash")))) - (pp-list (convert-hash obj expr?) extra pp-expr #f depth - pair? car cdr pair-open pair-close - qd))] - [(and (box? obj) print-box?) - (let ([qd (to-quoted out qd obj)]) - (if (and qd (zero? qd)) - (pp-pair (list (make-unquoted 'box) (unbox obj)) - extra depth - pair? car cdr pair-open pair-close - qd) - (begin - (out "#&") - (pr (unbox obj) extra pp-pair depth qd))))]) - (post-print pport obj))))) - ;; Not possible to split obj across lines; so just write directly - (wr* pport obj depth display? qd)))) - - (define (pp-expr expr extra depth - apair? acar acdr open close - qd) - (if (and (read-macro? expr apair? acar acdr qd) - (equal? open "(") - (not (and found (hash-ref found (acdr expr) #f)))) - (begin - (out (read-macro-prefix expr acar)) - (pr (read-macro-body expr acar acdr) - extra - pp-expr - depth - qd)) - (let ((head (acar expr))) - (if (or (and (symbol? head) - (not (size-hook head display?))) - ((pretty-print-remap-stylable) head)) - (let ((proc (style head expr apair? acar acdr))) - (if proc - (let* ([qd (to-quoted out qd expr)] - [pair (if (and qd (zero? qd)) - (cons (make-unquoted 'list) obj) - obj)]) - (proc expr extra depth - apair? acar acdr open close - qd)) - (if (and #f - ;; Why this special case? Currently disabled. - (> (string-length - (symbol->string - (if (symbol? head) - head - ((pretty-print-remap-stylable) head)))) - max-call-head-width)) - (pp-general expr extra #f #f #f pp-expr depth - apair? acar acdr open close - qd) - (pp-list expr extra pp-expr #t depth - apair? acar acdr open close - qd)))) - (pp-list expr extra pp-expr #t depth - apair? acar acdr open close - qd))))) - - (define (wr obj depth qd) - (wr* pport obj depth display? qd)) - - ;; (head item1 - ;; item2 - ;; item3) - (define (pp-call expr extra pp-item depth - apair? acar acdr open close - qd) - (out open) - (wr (acar expr) (dsub1 depth) qd) - (let ([col (+ (ccol) 1)]) - (pp-down close (acdr expr) col col extra pp-item #t #t depth - apair? acar acdr open close - qd))) - - ;; (head item1 item2 - ;; item3 - ;; item4) - (define (pp-two-up expr extra pp-item depth - apair? acar acdr open close - qd) - (out open) - (let ([col (ccol)]) - (wr (acar expr) (dsub1 depth) qd) - (out " ") - (wr (acar (acdr expr)) (dsub1 depth) qd) - (pp-down close (acdr (acdr expr)) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth - apair? acar acdr open close - qd))) - - ;; (head item1 - ;; item2 - ;; item3) - (define (pp-one-up expr extra pp-item depth - apair? acar acdr open close - qd) - (out open) - (let ([col (ccol)]) - (wr (acar expr) (dsub1 depth) qd) - (pp-down close (acdr expr) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth - apair? acar acdr open close - qd))) - - ;; (item1 - ;; item2 - ;; item3) - (define (pp-list l extra pp-item check? depth - apair? acar acdr open close - qd) - (out open) - (let ([col (ccol)]) - (pp-down close l col col extra pp-item #f check? depth - apair? acar acdr open close - qd))) - - (define (pp-down closer l col1 col2 extra pp-item check-first? check-rest? depth - apair? acar acdr open close - qd) - (let loop ([l l] [icol col1] [check? check-first?]) - (check-expr-found - l pport (and check? (apair? l)) - (lambda (s) - (indent col2) - (out ".") - (indent col2) - (out s) - (out closer)) - (lambda () - (indent col2) - (out ".") - (indent col2) - (pr l extra pp-item depth qd) - (out closer)) - (lambda () - (cond - [(apair? l) - (let ([rest (acdr l)]) - (let ([extra (if (null? rest) (+ extra 1) 0)]) - (indent icol) - (pr (acar l) extra pp-item (dsub1 depth) qd) - (loop rest col2 check-rest?)))] - [(null? l) - (out closer)] - [else - (indent col2) - (out ".") - (indent col2) - (pr l (+ extra 1) pp-item (dsub1 depth) qd) - (out closer)]))))) - - (define (pp-general expr extra named? pp-1 pp-2 pp-3 depth - apair? acar acdr open close - qd) - - (define (tail1 rest col1 col3) - (if (and pp-1 (apair? rest)) - (let* ((val1 (acar rest)) - (rest (acdr rest)) - (extra (if (null? rest) (+ extra 1) 0))) - (indent col3) - (pr val1 extra pp-1 depth qd) - (tail2 rest col1 col3)) - (tail2 rest col1 col3))) - - (define (tail2 rest col1 col3) - (if (and pp-2 (apair? rest)) - (let* ((val1 (acar rest)) - (rest (acdr rest)) - (extra (if (null? rest) (+ extra 1) 0))) - (indent col3) - (pr val1 extra pp-2 depth qd) - (tail3 rest col1)) - (tail3 rest col1))) - - (define (tail3 rest col1) - (pp-down close rest col1 col1 extra pp-3 #f #t depth - apair? acar acdr open close - qd)) - - (let* ([head (acar expr)] - [rest (acdr expr)] - [col (ccol)]) - (out open) - (wr head (dsub1 depth) qd) - (if (and named? (apair? rest)) - (let* ((name (acar rest)) - (rest (acdr rest))) - (out " ") - (wr name (dsub1 depth) qd) - (tail1 rest (+ col indent-general) (+ (ccol) 1))) - (tail1 rest (+ col indent-general) (+ (ccol) 1))))) - - (define (pp-expr-list l extra depth - apair? acar acdr open close - qd) - (pp-list l extra pp-expr #t depth - apair? acar acdr open close - qd)) - - (define (pp-lambda expr extra depth - apair? acar acdr open close - qd) - (pp-general expr extra #f pp-expr-list #f pp-expr depth - apair? acar acdr open close - qd)) - - (define (pp-if expr extra depth - apair? acar acdr open close - qd) - (pp-general expr extra #f pp-expr #f pp-expr depth - apair? acar acdr open close - qd)) - - (define (pp-cond expr extra depth - apair? acar acdr open close - qd) - (pp-list expr extra pp-expr-list #t depth - apair? acar acdr open close - qd)) - - (define (pp-syntax-case expr extra depth - apair? acar acdr open close - qd) - (pp-two-up expr extra pp-expr-list depth - apair? acar acdr open close - qd)) - - (define (pp-module expr extra depth - apair? acar acdr open close - qd) - (pp-two-up expr extra pp-expr depth - apair? acar acdr open close - qd)) - - (define (pp-make-object expr extra depth - apair? acar acdr open close - qd) - (pp-one-up expr extra pp-expr-list depth - apair? acar acdr open close - qd)) - - (define (pp-case expr extra depth - apair? acar acdr open close - qd) - (pp-general expr extra #f pp-expr #f pp-expr-list depth - apair? acar acdr open close - qd)) - - (define (pp-and expr extra depth - apair? acar acdr open close - qd) - (pp-call expr extra pp-expr depth - apair? acar acdr open close - qd)) - - (define (pp-let expr extra depth - apair? acar acdr open close - qd) - (let* ((rest (acdr expr)) - (named? (and (apair? rest) (symbol? (do-remap (acar rest)))))) - (pp-general expr extra named? pp-expr-list #f pp-expr depth - apair? acar acdr open close - qd))) - - (define (pp-begin expr extra depth - apair? acar acdr open close - qd) - (pp-general expr extra #f #f #f pp-expr depth - apair? acar acdr open close - qd)) - - (define (pp-do expr extra depth - apair? acar acdr open close - qd) - (pp-general expr extra #f pp-expr-list pp-expr-list pp-expr depth - apair? acar acdr open close - qd)) - - ;; define formatting style (change these to suit your style) - - (define indent-general 2) - - (define max-call-head-width 5) - - (define (no-sharing? expr count apair? acdr) - (if (apair? expr) - (if (and found - (hash-ref found (acdr expr) #f)) - #f - (or (zero? count) - (no-sharing? (acdr expr) (sub1 count) apair? acdr))) - #f)) - - (define (style head expr apair? acar acdr) - (case (look-in-style-table head) - ((lambda λ define define-macro define-syntax - syntax-rules - shared - unless when) - (and (no-sharing? expr 1 apair? acdr) - pp-lambda)) - ((if set! set!-values) - (and (no-sharing? expr 1 apair? acdr) - pp-if)) - ((cond case-lambda) - (and (no-sharing? expr 0 apair? acdr) - pp-cond)) - ((case class) - (and (no-sharing? expr 1 apair? acdr) - pp-case)) - ((and or import export - require require-for-syntax require-for-template - provide link - public private override rename inherit field init) - (and (no-sharing? expr 0 apair? acdr) - pp-and)) - ((let letrec let* - let-values letrec-values let*-values - let-syntax letrec-syntax - let-syntaxes letrec-syntaxes) - (and (no-sharing? expr - (if (and (apair? (acdr expr)) - (symbol? (acar (acdr expr)))) - 2 - 1) - apair? - acdr) - pp-let)) - ((begin begin0) - (and (no-sharing? expr 0 apair? acdr) - pp-begin)) - ((do letrec-syntaxes+values) - (and (no-sharing? expr 2 apair? acdr) - pp-do)) - ((module) - (and (no-sharing? expr 2 apair? acdr) - pp-module)) - ((send syntax-case instantiate) - (and (no-sharing? expr 2 apair? acdr) - pp-syntax-case)) - ((make-object) - (and (no-sharing? expr 1 apair? acdr) - pp-make-object)) - - (else #f))) - - (pr obj 0 pp-expr depth qd)) - - (define (to-quoted out qd obj) - (and qd - (if (zero? qd) - (if (hash-ref escapes-table obj #f) - qd + (define __dummy__ + (when found-cycle + (let loop ([obj obj]) + (if (or (vector? obj) + (pair? obj) + (mpair? obj) + (and (box? obj) + print-box?) + (and (custom-write? obj) + (not (struct-type? obj))) + (and (struct? obj) print-struct?) + (and (hash? obj) print-hash-table?)) + ;; A little confusing: use #t for not-found + (let ([p (hash-ref table obj #t)]) + (when (not (mark? p)) + (if p (begin - (out "'") - (add1 qd))) - qd))) + (hash-set! table obj #f) + (cond + [(vector? obj) + (let ([len (vector-length obj)]) + (let vloop ([i 0]) + (unless (= i len) + (loop (vector-ref obj i)) + (vloop (add1 i)))))] + [(pair? obj) + (loop (car obj)) + (loop (cdr obj))] + [(mpair? obj) + (loop (mcar obj)) + (loop (mcdr obj))] + [(and (box? obj) print-box?) (loop (unbox obj))] + [(and (custom-write? obj) + (not (struct-type? obj))) + (loop (extract-sub-objects obj pport))] + [(struct? obj) + (for-each loop + (vector->list (struct->vector obj)))] + [(hash? obj) + (hash-for-each + obj + (lambda (k v) + (loop k) + (loop v)))])) + (begin + (hash-set! table obj + (make-mark #f (box #f))))))) + (void))))) - ;; ------------------------------------------------------------ - ;; This is where generic-write's body expressions start + (define escapes-table + (let* ([table (make-hasheq)] + [local-compound (and print-as-qq? + (make-hasheq))] + [is-compound! (lambda (obj) + (hash-set! local-compound obj #t))] + [escapes! (lambda (obj) + (hash-set! table obj #t) + #t)] + [orf (lambda (a b) (or a b))]) + (when print-as-qq? + (let loop ([obj obj]) + (cond + [(hash-ref table obj #f) + ;; already decided that it escapes + #t] + [(and local-compound + (hash-ref local-compound obj #f)) + ;; either still deciding (so assume #f) or + ;; already decided that no escape is needed + #f] + [else + (cond + [(vector? obj) + (is-compound! obj) + (let ([len (vector-length obj)]) + (let vloop ([esc? #f][i 0]) + (if (= i len) + (and esc? + (escapes! obj)) + (vloop (or (loop (vector-ref obj i)) esc?) + (add1 i)))))] + [(flvector? obj) + (is-compound! obj) + ;; always unquoted: + #t] + [(fxvector? obj) + (is-compound! obj) + ;; always unquoted: + #t] + [(pair? obj) + (is-compound! obj) + (and (orf (loop (car obj)) + (loop (cdr obj))) + (escapes! obj))] + [(mpair? obj) + (is-compound! obj) + (loop (mcar obj)) + (loop (mcdr obj)) + ;; always unquoted: + #t] + [(and (box? obj) print-box?) + (is-compound! obj) + (and (loop (unbox obj)) + (escapes! obj))] + [(and (custom-write? obj) + (not (struct-type? obj))) + (is-compound! obj) + (let ([kind (if (custom-print-quotable? obj) + (custom-print-quotable-accessor obj) + 'self)]) + (and (or (and (loop (extract-sub-objects obj pport)) + (not (memq kind '(self always)))) + (memq kind '(never))) + (escapes! obj)))] + [(struct? obj) + (is-compound! obj) + (and (or (loop (struct->vector obj)) + (not (prefab-struct-key obj))) + (escapes! obj))] + [(hash? obj) + (is-compound! obj) + (and (for/fold ([esc? #f]) ([(k v) (in-hash obj)]) + (or (orf (loop v) + (loop k)) + esc?)) + (escapes! obj))] + [else #f])]))) + table)) - ((printing-port-print-line pport) #t 0 width) - (let ([qd (if print-as-qq? qq-depth #f)]) - (let-values ([(l col p) (port-next-location pport)]) - (if (and width (not (eq? width 'infinity))) - (pp* pport obj depth display? qd) - (wr* pport obj depth display? qd)))) - (let-values ([(l col p) (port-next-location pport)]) - ((printing-port-print-line pport) #f col width))) + (define cycle-counter 0) + + (define found (if found-cycle + table + #f)) + + (define dsub1 (lambda (d) + (if d + (sub1 d) + #f))) + + (define (pre-print pport obj) + ((printing-port-pre-print pport) obj)) + (define (post-print pport obj) + ((printing-port-post-print pport) + obj)) + (define (output-hooked pport obj len display?) + ((printing-port-output-hooked pport) + obj len display?)) + + (define expr-found + (lambda (pport ref) + (let ([n cycle-counter]) + (set! cycle-counter (add1 cycle-counter)) + (set-mark-str! ref + (string-append "#" + (number->string n) + "#")) + (set-mark-def! ref (printing-port-def-box pport)) + (display (string-append "#" + (number->string n) + "=") + pport)))) - (define (look-in-style-table raw-head) - (let ([head (do-remap raw-head)]) - (or (hash-ref (pretty-print-style-table-hash - (pretty-print-current-style-table)) - head - #f) - head))) + (define check-expr-found + (lambda (obj pport check? c-k d-k n-k) + (let ([ref (and check? + found + (hash-ref found obj #f))]) + (if (and ref (unbox (mark-def ref))) + (if c-k + (c-k (mark-str ref)) + (display (mark-str ref) pport)) + (if (and ref d-k) + (d-k) + (begin + (when ref + (expr-found pport ref)) + (n-k))))))) + + (define (write-custom recur obj pport depth display? width qd multi-line?) + (let-values ([(l c p) (port-next-location pport)]) + (let ([p (relocate-output-port pport l c p)]) + (port-count-lines! p) + (let ([writer (lambda (v port) + (recur port v (dsub1 depth) #f #f))] + [displayer (lambda (v port) + (recur port v (dsub1 depth) #t #f))] + [printer (case-lambda + [(v port) (recur port v (dsub1 depth) #f qd)] + [(v port qd) (recur port v (dsub1 depth) #f qd)])]) + (port-write-handler p writer) + (port-display-handler p displayer) + (port-print-handler p printer)) + (let ([p (register-printing-port-like p pport)]) + (parameterize ([pretty-printing multi-line?] + [pretty-print-columns (or width 'infinity)]) + ((custom-write-accessor obj) obj p (or qd (not display?)))))))) + + ;; ------------------------------------------------------------ - (define (do-remap raw-head) + (define (convert-pair obj) (cond - [((pretty-print-remap-stylable) raw-head) - => - values] - [else raw-head])) - - (define (read-macro? l pair? car cdr qd) - (define (length1? l) (and (pair? l) (null? (cdr l)))) - (and (pretty-print-abbreviate-read-macros) - (let ((head (do-remap (car l))) (tail (cdr l))) - (case head - ((quote quasiquote syntax - quasisyntax unsyntax unsyntax-splicing - unquote unquote-splicing) - (length1? tail)) - (else #f))))) - - (define (read-macro-body l car cdr) - (car (cdr l))) - - (define (read-macro-prefix l car) - (let ((head (do-remap (car l)))) - (case head - ((quote) "'") - ((quasiquote) "`") - ((unquote) ",") - ((unquote-splicing) ",@") - ((syntax) "#'") - ((quasisyntax) "#`") - ((unsyntax) "#,") - ((unsyntax-splicing) "#,@")))) - - (define pretty-print-handler - (lambda (v) - (unless (void? v) - (pretty-print v)))) + [(list? obj) (cons (make-unquoted 'list) + ;; reconstruct first pair in case it + ;; starts a cycle: + (cons (car obj) (cdr obj)))] + [(and (pair? (cdr obj)) + (not (and found + (hash-ref found (cdr obj) #f)))) + (cons (make-unquoted 'list*) + (cons + (car obj) + (let loop ([obj (cdr obj)]) + (cond + [(and found (hash-ref found obj #f)) (list obj)] + [(pair? obj) (cons (car obj) (loop (cdr obj)))] + [else (list obj)]))))] + [else (list (make-unquoted 'cons) (car obj) (cdr obj))])) - (define (number->decimal-string x) - (cond - [(or (inexact? x) - (integer? x)) - (number->string x)] - [(not (real? x)) - (let ([r (real-part x)] - [i (imag-part x)]) - (format "~a~a~ai" - (number->decimal-string r) - (if (negative? i) - "" - "+") - (number->decimal-string i)))] - [else - (let ([n (numerator x)] - [d (denominator x)]) - ;; Count powers of 2 in denomintor - (let loop ([v d][2-power 0]) - (if (and (positive? v) - (even? v)) - (loop (arithmetic-shift v -1) (add1 2-power)) - ;; Count powers of 5 in denominator - (let loop ([v v][5-power 0]) - (if (zero? (remainder v 5)) - (loop (quotient v 5) (add1 5-power)) - ;; No more 2s or 5s. Anything left? - (if (= v 1) - ;; Denominator = (* (expt 2 2-power) (expt 5 5-power)). - ;; Print number as decimal. - (let* ([10-power (max 2-power 5-power)] - [scale (* (expt 2 (- 10-power 2-power)) - (expt 5 (- 10-power 5-power)))] - [s (number->string (* (abs n) scale))] - [orig-len (string-length s)] - [len (max (add1 10-power) orig-len)] - [padded-s (if (< orig-len len) - (string-append - (make-string (- len orig-len) #\0) - s) - s)]) - (format "~a~a.~a" - (if (negative? n) "-" "") - (substring padded-s 0 (- len 10-power)) - (substring padded-s (- len 10-power) len))) - ;; d has factor(s) other than 2 and 5. - ;; Print as a fraction. - (number->string x)))))))])) + (define (convert-hash obj expr?) + (let ([l (hash-map obj (lambda (k v) + (if expr? + (list k v) + (cons k (make-hide v)))))]) + (if expr? + (cons (make-unquoted + (if (hash-eq? obj) + 'hasheq + (if (hash-eqv? obj) + 'hasheqv + 'hash))) + (apply append l)) + l))) - (define (pretty-format t [w (pretty-print-columns)] #:mode [mode 'print]) - (parameterize ([pretty-print-columns w]) - (let ([op (open-output-string)]) - ((case mode - [(print) pretty-print] - [(write) pretty-write] - [(display) pretty-display] - [else (raise-argument-error 'pretty-format "(or/c 'print 'write display)" mode)]) - t op) - (let ([s (get-output-string op)]) - (if (eq? w 'infinity) - s - (substring s 0 (- (string-length s) 1))))))) + ;; ------------------------------------------------------------ + ;; wr: write on a single line + (define (wr* pport obj depth display? qd) + + (define (out str) + (write-string str pport)) + + (define (wr obj depth qd) + (wr* pport obj depth display? qd)) + + (define (wr-expr expr depth pair? car cdr open close qd) + (if (and (read-macro? expr pair? car cdr qd) + (equal? open "(")) + (begin + (out (read-macro-prefix expr car)) + (wr (read-macro-body expr car cdr) depth qd)) + (wr-lst expr #t depth pair? car cdr open close qd))) + + (define (wr-lst l check? depth pair? car cdr open close qd) + (if (pair? l) + (if (and depth (zero? depth)) + (begin + (out open) + (out "...") + (out close)) + (begin + (out open) + (wr (car l) (dsub1 depth) qd) + (let loop ([l (cdr l)]) + (check-expr-found + l pport (and check? (pair? l)) + (lambda (s) (out " . ") (out s) (out close)) + (lambda () + (out " . ") + (check-expr-found ;; will find it! + l pport #t + #f #f + (lambda () + (wr-lst l check? (dsub1 depth) pair? car cdr open close qd))) + (out close)) + (lambda () + (cond + [(pair? l) + (if (and (eq? (do-remap (car l)) 'unquote) + (not (equal? qd 1)) + (pair? (cdr l)) + (null? (cdr (cdr l)))) + (begin + (out " . ,") + (wr (car (cdr l)) (dsub1 depth) qd) + (out close)) + (begin + (out " ") + (wr (car l) (dsub1 depth) qd) + (loop (cdr l))))] + [(null? l) (out close)] + [else + (out " . ") + (wr l (dsub1 depth) qd) + (out close)])))))) + (begin + (out open) + (out close)))) + + (unless (hide? obj) + (pre-print pport obj)) + (if (and depth + (negative? depth) + (not (hide? obj))) + (out "...") + + (cond + [(size-hook obj display?) + => (lambda (len) + (output-hooked pport obj len display?))] + + [(pair? obj) + (check-expr-found + obj pport #t + #f #f + (lambda () + (let* ([qd (to-quoted out qd obj)] + [pair (if (and qd (zero? qd)) + (convert-pair obj) + obj)]) + (wr-expr pair depth pair? car cdr pair-open pair-close qd))))] + [(mpair? obj) + (check-expr-found + obj pport #t + #f #f + (lambda () + (if (and qd (zero? qd)) + (wr-expr (list (make-unquoted 'mcons) (mcar obj) (mcdr obj)) + depth pair? car cdr pair-open pair-close qd) + (wr-expr obj depth mpair? mcar mcdr mpair-open mpair-close qd))))] + [(null? obj) + (let ([qd (to-quoted out qd obj)]) + (wr-lst obj #f depth pair? car cdr "(" ")" qd))] + [(vector? obj) + (check-expr-found + obj pport #t + #f #f + (lambda () + (let ([qd (to-quoted out qd obj)] + [vecl (vector->repeatless-list obj)]) + (if (and qd (zero? qd)) + (wr-lst (cons (make-unquoted 'vector) vecl) + #f depth pair? car cdr "(" ")" qd) + (begin + (out "#") + (when print-vec-length? + (out (number->string (vector-length obj)))) + (wr-lst vecl #f depth pair? car cdr "(" ")" qd))))))] + [(flvector? obj) + (check-expr-found + obj pport #t + #f #f + (lambda () + (let ([vecl (flvector->repeatless-list obj)]) + (if (and qd (zero? qd)) + (wr-lst (cons (make-unquoted 'flvector) vecl) + #f depth pair? car cdr "(" ")" qd) + (begin + (out "#fl") + (when print-vec-length? + (out (number->string (flvector-length obj)))) + (wr-lst vecl #f depth pair? car cdr "(" ")" qd))))))] + [(fxvector? obj) + (check-expr-found + obj pport #t + #f #f + (lambda () + (let ([vecl (fxvector->repeatless-list obj)]) + (if (and qd (zero? qd)) + (wr-lst (cons (make-unquoted 'fxvector) vecl) + #f depth pair? car cdr "(" ")" qd) + (begin + (out "#fx") + (when print-vec-length? + (out (number->string (fxvector-length obj)))) + (wr-lst vecl #f depth pair? car cdr "(" ")" qd))))))] + [(and (box? obj) + print-box?) + (check-expr-found + obj pport #t + #f #f + (lambda () + (let ([qd (to-quoted out qd obj)]) + (if (and qd (zero? qd)) + (wr-lst (list (make-unquoted 'box) (unbox obj)) + #f depth pair? car cdr "(" ")" qd) + (begin + (out "#&") + (wr (unbox obj) (dsub1 depth) qd))))))] + [(and (custom-write? obj) + (not (struct-type? obj))) + (check-expr-found + obj pport #t + #f #f + (lambda () + (parameterize ([pretty-print-columns 'infinity]) + (let ([qd (let ([kind (if (custom-print-quotable? obj) + (custom-print-quotable-accessor obj) + 'self)]) + (if (memq kind '(self never)) + qd + (to-quoted out qd obj)))]) + (write-custom wr* obj pport depth display? width qd #f)))))] + [(hide? obj) + (wr* pport (hide-val obj) depth display? qd)] + [(unquoted? obj) + (orig-write (unquoted-val obj) pport)] + [(struct? obj) + (if (and print-struct? + (not (and depth + (zero? depth)))) + (check-expr-found + obj pport #t + #f #f + (lambda () + (let* ([v (struct->vector obj struct-ellipses)] + [pf? (prefab?! obj v)]) + (let ([qd (if pf? + (to-quoted out qd obj) + qd)]) + (when (or (not qd) (positive? qd)) + (out "#") + (when pf? (out "s"))) + (wr-lst (let ([l (vector->list v)]) + (if (and qd (zero? qd)) + (cons (make-unquoted (object-name obj)) + (cdr l)) + l)) + #f (dsub1 depth) pair? car cdr "(" ")" + qd))))) + (parameterize ([print-struct #f]) + ((if display? orig-display orig-write) obj pport)))] + [(hash? obj) + (if (and print-hash-table? + (not (and depth + (zero? depth)))) + (check-expr-found + obj pport #t + #f #f + (lambda () + (let* ([qd (to-quoted out qd obj)] + [expr? (and qd (zero? qd))]) + (unless expr? + (out (if (hash-eq? obj) + "#hasheq" + (if (hash-eqv? obj) + "#hasheqv" + "#hash")))) + (wr-lst (convert-hash obj expr?) + #f depth + pair? car cdr "(" ")" qd)))) + (parameterize ([print-hash-table #f]) + ((if display? orig-display orig-write) obj pport)))] + [(boolean? obj) + (out (if long-bools? + (if obj "#true" "#false") + (if obj "#t" "#f")))] + [(number? obj) + (when (and show-inexactness? + (inexact? obj)) + (out "#i")) + (out ((if exact-as-decimal? + number->decimal-string + number->string) + obj))] + [(and (pretty-print-.-symbol-without-bars) + (eq? obj '|.|)) + (out ".")] + [(and qd (or (symbol? obj) + (keyword? obj))) + (unless (eq? obj struct-ellipses) + (to-quoted out qd obj)) + (orig-write obj pport)] + [else + ((if display? orig-display orig-write) obj pport)])) + (unless (hide? obj) + (post-print pport obj))) + + ;; ------------------------------------------------------------ + ;; pp: write on (potentially) multiple lines + (define (pp* pport obj depth display? qd) + + (define (pp obj depth) + (pp* pport obj depth display? qd)) + + (define (out str) + (write-string str pport)) + + (define (spaces n) + (add-spaces n pport)) + + (define (ccol) + (let-values ([(l col p) (port-next-location pport)]) + col)) + + (define (indent to) + (let ([col (ccol)]) + (if (< to col) + (begin + (let ([col ((printing-port-print-line pport) #t col width)]) + (spaces (- to col)))) + (spaces (max 0 (- to col)))))) + + (define (pr obj extra pp-pair depth qd) + ;; may have to split on multiple lines + (let* ([obj (if (hide? obj) (hide-val obj) obj)] + [can-multi (and width + (not (size-hook obj display?)) + (or (pair? obj) + (mpair? obj) + (vector? obj) + (flvector? obj) + (fxvector? obj) + (and (box? obj) print-box?) + (and (custom-write? obj) + (not (struct-type? obj))) + (and (struct? obj) print-struct?) + (and (hash? obj) print-hash-table?)))] + [graph-ref (if can-multi + (and found (hash-ref found obj #f)) + #f)] + [old-counter cycle-counter]) + (if (and can-multi + (or (not graph-ref) + (not (unbox (mark-def graph-ref))))) + ;; It might be possible to split obj across lines. + ;; Try writing the obj, but accumulate the info that goes out + ;; into a-pport + (let ([a-pport + (let/ec esc + (letrec ([a-pport (make-tentative-output-port + pport + (- width extra) + (lambda () (esc a-pport)))]) + ;; Here's the attempt to write on one line: + (wr* a-pport obj depth display? qd) + a-pport))]) + (let-values ([(l c p) (port-next-location a-pport)]) + (if (<= c (- width extra)) + ;; All can be printed on one line, so just dump the + ;; accumulated text + (tentative-pretty-print-port-transfer a-pport pport) + ;; Doesn't fit on one line, so start over + (begin + (tentative-pretty-print-port-cancel a-pport) + (set! cycle-counter old-counter) + (when graph-ref + (expr-found pport graph-ref)) + (pre-print pport obj) + (cond + [(pair? obj) + (let* ([qd (to-quoted out qd obj)] + [pair (if (and qd (zero? qd)) + (convert-pair obj) + obj)]) + (pp-pair pair extra depth + pair? car cdr pair-open pair-close + qd))] + [(mpair? obj) + (if (and qd (zero? qd)) + (pp-pair (list (make-unquoted 'mcons) (mcar obj) (mcdr obj)) + extra depth + pair? car cdr pair-open pair-close + qd) + (pp-pair obj extra depth + mpair? mcar mcdr mpair-open mpair-close + qd))] + [(vector? obj) + (let ([qd (to-quoted out qd obj)] + [vecl (vector->repeatless-list obj)]) + (if (and qd (zero? qd)) + (pp-pair (cons (make-unquoted 'vector) vecl) + extra depth + pair? car cdr pair-open pair-close + qd) + (begin + (out "#") + (when print-vec-length? + (out (number->string (vector-length obj)))) + (pp-list vecl extra pp-expr #f depth + pair? car cdr pair-open pair-close + qd))))] + [(flvector? obj) + (let ([vecl (flvector->repeatless-list obj)]) + (if (and qd (zero? qd)) + (pp-pair (cons (make-unquoted 'flvector) vecl) + extra depth + pair? car cdr pair-open pair-close + qd) + (begin + (out "#fl") + (when print-vec-length? + (out (number->string (flvector-length obj)))) + (pp-list vecl extra pp-expr #f depth + pair? car cdr pair-open pair-close + qd))))] + [(fxvector? obj) + (let ([vecl (fxvector->repeatless-list obj)]) + (if (and qd (zero? qd)) + (pp-pair (cons (make-unquoted 'fxvector) vecl) + extra depth + pair? car cdr pair-open pair-close + qd) + (begin + (out "#fx") + (when print-vec-length? + (out (number->string (fxvector-length obj)))) + (pp-list vecl extra pp-expr #f depth + pair? car cdr pair-open pair-close + qd))))] + [(and (custom-write? obj) + (not (struct-type? obj))) + (let ([qd (let ([kind (if (custom-print-quotable? obj) + (custom-print-quotable-accessor obj) + 'self)]) + (if (memq kind '(self never)) + qd + (to-quoted out qd obj)))]) + (write-custom pp* obj pport depth display? width qd #t))] + [(struct? obj) ; print-struct is on if we got here + (let* ([v (struct->vector obj struct-ellipses)] + [pf? (prefab?! obj v)]) + (let ([qd (if pf? + (to-quoted out qd obj) + qd)]) + (when (or (not qd) (positive? qd)) + (out "#") + (when pf? (out "s"))) + (pp-list (let ([l (vector->list v)]) + (if (and qd (zero? qd)) + (cons (make-unquoted (object-name obj)) + (cdr l)) + l)) + extra pp-expr #f depth + pair? car cdr pair-open pair-close + qd)))] + [(hash? obj) + (let* ([qd (to-quoted out qd obj)] + [expr? (and qd (zero? qd))]) + (unless expr? + (out (if (hash-eq? obj) + "#hasheq" + (if (hash-eqv? obj) + "#hasheqv" + "#hash")))) + (pp-list (convert-hash obj expr?) extra pp-expr #f depth + pair? car cdr pair-open pair-close + qd))] + [(and (box? obj) print-box?) + (let ([qd (to-quoted out qd obj)]) + (if (and qd (zero? qd)) + (pp-pair (list (make-unquoted 'box) (unbox obj)) + extra depth + pair? car cdr pair-open pair-close + qd) + (begin + (out "#&") + (pr (unbox obj) extra pp-pair depth qd))))]) + (post-print pport obj))))) + ;; Not possible to split obj across lines; so just write directly + (wr* pport obj depth display? qd)))) + + (define (pp-expr expr extra depth + apair? acar acdr open close + qd) + (if (and (read-macro? expr apair? acar acdr qd) + (equal? open "(") + (not (and found (hash-ref found (acdr expr) #f)))) + (begin + (out (read-macro-prefix expr acar)) + (pr (read-macro-body expr acar acdr) + extra + pp-expr + depth + qd)) + (let ((head (acar expr))) + (if (or (and (symbol? head) + (not (size-hook head display?))) + ((pretty-print-remap-stylable) head)) + (let ((proc (style head expr apair? acar acdr))) + (if proc + (let* ([qd (to-quoted out qd expr)] + [pair (if (and qd (zero? qd)) + (cons (make-unquoted 'list) obj) + obj)]) + (proc expr extra depth + apair? acar acdr open close + qd)) + (if (and #f + ;; Why this special case? Currently disabled. + (> (string-length + (symbol->string + (if (symbol? head) + head + ((pretty-print-remap-stylable) head)))) + max-call-head-width)) + (pp-general expr extra #f #f #f pp-expr depth + apair? acar acdr open close + qd) + (pp-list expr extra pp-expr #t depth + apair? acar acdr open close + qd)))) + (pp-list expr extra pp-expr #t depth + apair? acar acdr open close + qd))))) + + (define (wr obj depth qd) + (wr* pport obj depth display? qd)) + + ;; (head item1 + ;; item2 + ;; item3) + (define (pp-call expr extra pp-item depth + apair? acar acdr open close + qd) + (out open) + (wr (acar expr) (dsub1 depth) qd) + (let ([col (+ (ccol) 1)]) + (pp-down close (acdr expr) col col extra pp-item #t #t depth + apair? acar acdr open close + qd))) + + ;; (head item1 item2 + ;; item3 + ;; item4) + (define (pp-two-up expr extra pp-item depth + apair? acar acdr open close + qd) + (out open) + (let ([col (ccol)]) + (wr (acar expr) (dsub1 depth) qd) + (out " ") + (wr (acar (acdr expr)) (dsub1 depth) qd) + (pp-down close (acdr (acdr expr)) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth + apair? acar acdr open close + qd))) + + ;; (head item1 + ;; item2 + ;; item3) + (define (pp-one-up expr extra pp-item depth + apair? acar acdr open close + qd) + (out open) + (let ([col (ccol)]) + (wr (acar expr) (dsub1 depth) qd) + (pp-down close (acdr expr) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth + apair? acar acdr open close + qd))) + + ;; (item1 + ;; item2 + ;; item3) + (define (pp-list l extra pp-item check? depth + apair? acar acdr open close + qd) + (out open) + (let ([col (ccol)]) + (pp-down close l col col extra pp-item #f check? depth + apair? acar acdr open close + qd))) + + (define (pp-down closer l col1 col2 extra pp-item check-first? check-rest? depth + apair? acar acdr open close + qd) + (let loop ([l l] [icol col1] [check? check-first?]) + (check-expr-found + l pport (and check? (apair? l)) + (lambda (s) + (indent col2) + (out ".") + (indent col2) + (out s) + (out closer)) + (lambda () + (indent col2) + (out ".") + (indent col2) + (pr l extra pp-item depth qd) + (out closer)) + (lambda () + (cond + [(apair? l) + (let ([rest (acdr l)]) + (let ([extra (if (null? rest) (+ extra 1) 0)]) + (indent icol) + (pr (acar l) extra pp-item (dsub1 depth) qd) + (loop rest col2 check-rest?)))] + [(null? l) + (out closer)] + [else + (indent col2) + (out ".") + (indent col2) + (pr l (+ extra 1) pp-item (dsub1 depth) qd) + (out closer)]))))) + + (define (pp-general expr extra named? pp-1 pp-2 pp-3 depth + apair? acar acdr open close + qd) + + (define (tail1 rest col1 col3) + (if (and pp-1 (apair? rest)) + (let* ((val1 (acar rest)) + (rest (acdr rest)) + (extra (if (null? rest) (+ extra 1) 0))) + (indent col3) + (pr val1 extra pp-1 depth qd) + (tail2 rest col1 col3)) + (tail2 rest col1 col3))) + + (define (tail2 rest col1 col3) + (if (and pp-2 (apair? rest)) + (let* ((val1 (acar rest)) + (rest (acdr rest)) + (extra (if (null? rest) (+ extra 1) 0))) + (indent col3) + (pr val1 extra pp-2 depth qd) + (tail3 rest col1)) + (tail3 rest col1))) + + (define (tail3 rest col1) + (pp-down close rest col1 col1 extra pp-3 #f #t depth + apair? acar acdr open close + qd)) + + (let* ([head (acar expr)] + [rest (acdr expr)] + [col (ccol)]) + (out open) + (wr head (dsub1 depth) qd) + (if (and named? (apair? rest)) + (let* ((name (acar rest)) + (rest (acdr rest))) + (out " ") + (wr name (dsub1 depth) qd) + (tail1 rest (+ col indent-general) (+ (ccol) 1))) + (tail1 rest (+ col indent-general) (+ (ccol) 1))))) + + (define (pp-expr-list l extra depth + apair? acar acdr open close + qd) + (pp-list l extra pp-expr #t depth + apair? acar acdr open close + qd)) + + (define (pp-lambda expr extra depth + apair? acar acdr open close + qd) + (pp-general expr extra #f pp-expr-list #f pp-expr depth + apair? acar acdr open close + qd)) + + (define (pp-if expr extra depth + apair? acar acdr open close + qd) + (pp-general expr extra #f pp-expr #f pp-expr depth + apair? acar acdr open close + qd)) + + (define (pp-cond expr extra depth + apair? acar acdr open close + qd) + (pp-list expr extra pp-expr-list #t depth + apair? acar acdr open close + qd)) + + (define (pp-syntax-case expr extra depth + apair? acar acdr open close + qd) + (pp-two-up expr extra pp-expr-list depth + apair? acar acdr open close + qd)) + + (define (pp-module expr extra depth + apair? acar acdr open close + qd) + (pp-two-up expr extra pp-expr depth + apair? acar acdr open close + qd)) + + (define (pp-make-object expr extra depth + apair? acar acdr open close + qd) + (pp-one-up expr extra pp-expr-list depth + apair? acar acdr open close + qd)) + + (define (pp-case expr extra depth + apair? acar acdr open close + qd) + (pp-general expr extra #f pp-expr #f pp-expr-list depth + apair? acar acdr open close + qd)) + + (define (pp-and expr extra depth + apair? acar acdr open close + qd) + (pp-call expr extra pp-expr depth + apair? acar acdr open close + qd)) + + (define (pp-let expr extra depth + apair? acar acdr open close + qd) + (let* ((rest (acdr expr)) + (named? (and (apair? rest) (symbol? (do-remap (acar rest)))))) + (pp-general expr extra named? pp-expr-list #f pp-expr depth + apair? acar acdr open close + qd))) + + (define (pp-begin expr extra depth + apair? acar acdr open close + qd) + (pp-general expr extra #f #f #f pp-expr depth + apair? acar acdr open close + qd)) + + (define (pp-do expr extra depth + apair? acar acdr open close + qd) + (pp-general expr extra #f pp-expr-list pp-expr-list pp-expr depth + apair? acar acdr open close + qd)) + + ;; define formatting style (change these to suit your style) + + (define indent-general 2) + + (define max-call-head-width 5) + + (define (no-sharing? expr count apair? acdr) + (if (apair? expr) + (if (and found + (hash-ref found (acdr expr) #f)) + #f + (or (zero? count) + (no-sharing? (acdr expr) (sub1 count) apair? acdr))) + #f)) + + (define (style head expr apair? acar acdr) + (case (look-in-style-table head) + ((lambda λ define define-macro define-syntax + syntax-rules + shared + unless when) + (and (no-sharing? expr 1 apair? acdr) + pp-lambda)) + ((if set! set!-values) + (and (no-sharing? expr 1 apair? acdr) + pp-if)) + ((cond case-lambda) + (and (no-sharing? expr 0 apair? acdr) + pp-cond)) + ((case class) + (and (no-sharing? expr 1 apair? acdr) + pp-case)) + ((and or import export + require require-for-syntax require-for-template + provide link + public private override rename inherit field init) + (and (no-sharing? expr 0 apair? acdr) + pp-and)) + ((let letrec let* + let-values letrec-values let*-values + let-syntax letrec-syntax + let-syntaxes letrec-syntaxes) + (and (no-sharing? expr + (if (and (apair? (acdr expr)) + (symbol? (acar (acdr expr)))) + 2 + 1) + apair? + acdr) + pp-let)) + ((begin begin0) + (and (no-sharing? expr 0 apair? acdr) + pp-begin)) + ((do letrec-syntaxes+values) + (and (no-sharing? expr 2 apair? acdr) + pp-do)) + ((module) + (and (no-sharing? expr 2 apair? acdr) + pp-module)) + ((send syntax-case instantiate) + (and (no-sharing? expr 2 apair? acdr) + pp-syntax-case)) + ((make-object) + (and (no-sharing? expr 1 apair? acdr) + pp-make-object)) + + (else #f))) + + (pr obj 0 pp-expr depth qd)) + + (define (to-quoted out qd obj) + (and qd + (if (zero? qd) + (if (hash-ref escapes-table obj #f) + qd + (begin + (out "'") + (add1 qd))) + qd))) + + ;; ------------------------------------------------------------ + ;; This is where generic-write's body expressions start + + ((printing-port-print-line pport) #t 0 width) + (let ([qd (if print-as-qq? qq-depth #f)]) + (let-values ([(l col p) (port-next-location pport)]) + (if (and width (not (eq? width 'infinity))) + (pp* pport obj depth display? qd) + (wr* pport obj depth display? qd)))) + (when newline? + (let-values ([(l col p) (port-next-location pport)]) + ((printing-port-print-line pport) #f col width)))) + +(define (look-in-style-table raw-head) + (let ([head (do-remap raw-head)]) + (or (hash-ref (pretty-print-style-table-hash + (pretty-print-current-style-table)) + head + #f) + head))) + +(define (do-remap raw-head) + (cond + [((pretty-print-remap-stylable) raw-head) + => + values] + [else raw-head])) + +(define (read-macro? l pair? car cdr qd) + (define (length1? l) (and (pair? l) (null? (cdr l)))) + (and (pretty-print-abbreviate-read-macros) + (let ((head (do-remap (car l))) (tail (cdr l))) + (case head + ((quote quasiquote syntax + quasisyntax unsyntax unsyntax-splicing + unquote unquote-splicing) + (length1? tail)) + (else #f))))) + +(define (read-macro-body l car cdr) + (car (cdr l))) + +(define (read-macro-prefix l car) + (let ((head (do-remap (car l)))) + (case head + ((quote) "'") + ((quasiquote) "`") + ((unquote) ",") + ((unquote-splicing) ",@") + ((syntax) "#'") + ((quasisyntax) "#`") + ((unsyntax) "#,") + ((unsyntax-splicing) "#,@")))) + +(define pretty-print-handler + (lambda (v) + (unless (void? v) + (pretty-print v)))) + +(define (number->decimal-string x) + (cond + [(or (inexact? x) + (integer? x)) + (number->string x)] + [(not (real? x)) + (let ([r (real-part x)] + [i (imag-part x)]) + (format "~a~a~ai" + (number->decimal-string r) + (if (negative? i) + "" + "+") + (number->decimal-string i)))] + [else + (let ([n (numerator x)] + [d (denominator x)]) + ;; Count powers of 2 in denomintor + (let loop ([v d][2-power 0]) + (if (and (positive? v) + (even? v)) + (loop (arithmetic-shift v -1) (add1 2-power)) + ;; Count powers of 5 in denominator + (let loop ([v v][5-power 0]) + (if (zero? (remainder v 5)) + (loop (quotient v 5) (add1 5-power)) + ;; No more 2s or 5s. Anything left? + (if (= v 1) + ;; Denominator = (* (expt 2 2-power) (expt 5 5-power)). + ;; Print number as decimal. + (let* ([10-power (max 2-power 5-power)] + [scale (* (expt 2 (- 10-power 2-power)) + (expt 5 (- 10-power 5-power)))] + [s (number->string (* (abs n) scale))] + [orig-len (string-length s)] + [len (max (add1 10-power) orig-len)] + [padded-s (if (< orig-len len) + (string-append + (make-string (- len orig-len) #\0) + s) + s)]) + (format "~a~a.~a" + (if (negative? n) "-" "") + (substring padded-s 0 (- len 10-power)) + (substring padded-s (- len 10-power) len))) + ;; d has factor(s) other than 2 and 5. + ;; Print as a fraction. + (number->string x)))))))])) + +(define (pretty-format t [w (pretty-print-columns)] #:mode [mode 'print]) + (parameterize ([pretty-print-columns w]) + (let ([op (open-output-string)]) + ((case mode + [(print) pretty-print] + [(write) pretty-write] + [(display) pretty-display] + [else (raise-argument-error 'pretty-format "(or/c 'print 'write 'display)" mode)]) + t op #:newline? #f) + (get-output-string op)))) + + - - ) diff --git a/racket/collects/syntax/parse/experimental/template.rkt b/racket/collects/syntax/parse/experimental/template.rkt index d415813f97..ce8c864a90 100644 --- a/racket/collects/syntax/parse/experimental/template.rkt +++ b/racket/collects/syntax/parse/experimental/template.rkt @@ -42,6 +42,7 @@ A HeadTemplate (H) is one of: (begin-for-syntax (define (do-template ctx tstx quasi? loc-id) + (with-disappeared-uses (parameterize ((current-syntax-context ctx) (quasi (and quasi? (box null)))) (let*-values ([(guide deps props-guide) (parse-template tstx loc-id)] @@ -74,7 +75,7 @@ A HeadTemplate (H) is one of: (substitute (quote-syntax t) 'props-guide 'guide - vars-vector)))]))))))) + vars-vector)))])))))))) (define-syntax (template stx) (syntax-case stx () @@ -599,7 +600,8 @@ instead of integers and integer vectors. (values drivers #f guide props-guide))])) (define (lookup id depth) - (let ([v (syntax-local-value id (lambda () #f))]) + (let ([v (syntax-local-value/record id (lambda (v) (or (syntax-pattern-variable? v) + (template-metafunction? v))))]) (cond [(syntax-pattern-variable? v) (let* ([pvar-depth (syntax-mapping-depth v)] [attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))] diff --git a/racket/src/racket/gc2/gc2.h b/racket/src/racket/gc2/gc2.h index 724c99af58..e6fd92b5cd 100644 --- a/racket/src/racket/gc2/gc2.h +++ b/racket/src/racket/gc2/gc2.h @@ -145,6 +145,11 @@ GC2_EXTERN intptr_t GC_get_memory_use(void *c); Returns the number of currently-allocated bytes (speficilly for custodian c, as much as the GC's accounting makes possible). */ +GC2_EXTERN intptr_t GC_get_memory_ever_allocated(); +/* + Returns the number of total number of allocated bytes, including + bytes that have since been reclaimed. */ + GC2_EXTERN int GC_accouting_enabled(); /* Reports whether memory accounting is enabled. */ diff --git a/racket/src/racket/gc2/newgc.c b/racket/src/racket/gc2/newgc.c index 44ae026a1a..8caf3c530e 100644 --- a/racket/src/racket/gc2/newgc.c +++ b/racket/src/racket/gc2/newgc.c @@ -41,6 +41,9 @@ /* Avoid incremental GC if the heap seems to be getting too fragmented: */ #define HIGH_FRAGMENTATION_RATIO 2 +/* Initial and minimum value to treat as previous use after a full GC: */ +#define INITIAL_FULL_MEMORY_USE (20 * 1024 * 1024) + /* Whether to use a little aging, moving gen-0 objects to a gen-1/2 space: */ #define AGE_GEN_0_TO_GEN_HALF(gc) ((gc)->started_incremental) @@ -745,7 +748,7 @@ static void NewGC_initialize(NewGC *newgc, NewGC *inheritgc, NewGC *parentgc) { newgc->mmu = mmu_create(newgc); newgc->generations_available = 1; - newgc->last_full_mem_use = (20 * 1024 * 1024); + newgc->last_full_mem_use = INITIAL_FULL_MEMORY_USE; newgc->new_btc_mark = 1; newgc->place_memory_limit = (uintptr_t)(intptr_t)-1; @@ -973,6 +976,16 @@ intptr_t GC_get_memory_use(void *o) return (intptr_t)amt; } +intptr_t GC_get_memory_ever_allocated() +{ + NewGC *gc = GC_get_GC(); + uintptr_t amt; + + amt = add_no_overflow(gen0_size_in_use(gc), gc->total_memory_allocated); + + return (intptr_t)amt; +} + /*****************************************************************************/ /* Write barrier */ /* */ @@ -5314,6 +5327,8 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full, old_gen0 = gen0_size_in_use(gc) + gc->gen0_phantom_count; old_mem_allocated = mmu_memory_allocated(gc->mmu) + gc->phantom_count + gc->gen0_phantom_count; + gc->total_memory_allocated += old_gen0; + TIME_DECLS(); dump_page_map(gc, "pre"); @@ -5334,7 +5349,9 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full, This approach makes total memory use roughly a constant fraction of the actual use by live data: */ || (gc->memory_in_use > (FULL_COLLECTION_SIZE_RATIO - * gc->last_full_mem_use + * ((gc->last_full_mem_use < INITIAL_FULL_MEMORY_USE) + ? INITIAL_FULL_MEMORY_USE + : gc->last_full_mem_use) * (gc->incremental_requested ? INCREMENTAL_EXTRA_SIZE_RATIO : 1))) diff --git a/racket/src/racket/gc2/newgc.h b/racket/src/racket/gc2/newgc.h index e68b9bb822..c03b5d1489 100644 --- a/racket/src/racket/gc2/newgc.h +++ b/racket/src/racket/gc2/newgc.h @@ -312,6 +312,8 @@ typedef struct NewGC { uintptr_t minor_old_skipped; uintptr_t modified_unprotects; + uintptr_t total_memory_allocated; /* doesn't include current gen0 */ + /* THREAD_LOCAL variables that need to be saved off */ void *saved_GC_variable_stack; uintptr_t saved_GC_gen0_alloc_page_ptr; diff --git a/racket/src/racket/include/scheme.h b/racket/src/racket/include/scheme.h index 75379d55bd..2182d49a2e 100644 --- a/racket/src/racket/include/scheme.h +++ b/racket/src/racket/include/scheme.h @@ -1543,6 +1543,8 @@ struct Scheme_Input_Port #endif }; +#define SCHEME_INPORT_VAL(i) (((Scheme_Input_Port *)i)->port_data) + struct Scheme_Output_Port { struct Scheme_Port p; @@ -1566,6 +1568,8 @@ struct Scheme_Output_Port struct Scheme_Input_Port *input_half; }; +#define SCHEME_OUTPORT_VAL(o) (((Scheme_Output_Port *)o)->port_data) + #define SCHEME_SPECIAL (-2) #define SCHEME_UNLESS_READY (-3) diff --git a/racket/src/racket/include/schthread.h b/racket/src/racket/include/schthread.h index 29c76b764c..5aeb1e612c 100644 --- a/racket/src/racket/include/schthread.h +++ b/racket/src/racket/include/schthread.h @@ -337,6 +337,8 @@ typedef struct Thread_Local_Variables { struct Scheme_Thread *main_break_target_thread_; intptr_t scheme_code_page_total_; intptr_t max_gc_pre_used_bytes_; + int num_major_garbage_collections_; + int num_minor_garbage_collections_; int locale_on_; void *current_locale_name_ptr_; int gensym_counter_; @@ -736,6 +738,8 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define main_break_target_thread XOA (scheme_get_thread_local_variables()->main_break_target_thread_) #define scheme_code_page_total XOA (scheme_get_thread_local_variables()->scheme_code_page_total_) #define max_gc_pre_used_bytes XOA (scheme_get_thread_local_variables()->max_gc_pre_used_bytes_) +#define num_major_garbage_collections XOA (scheme_get_thread_local_variables()->num_major_garbage_collections_) +#define num_minor_garbage_collections XOA (scheme_get_thread_local_variables()->num_minor_garbage_collections_) #define locale_on XOA (scheme_get_thread_local_variables()->locale_on_) #define current_locale_name_ptr XOA (scheme_get_thread_local_variables()->current_locale_name_ptr_) #define gensym_counter XOA (scheme_get_thread_local_variables()->gensym_counter_) diff --git a/racket/src/racket/sgc/sgc.c b/racket/src/racket/sgc/sgc.c index cae121d6ca..54cf39106e 100644 --- a/racket/src/racket/sgc/sgc.c +++ b/racket/src/racket/sgc/sgc.c @@ -799,7 +799,7 @@ static intptr_t mem_use, mem_limit = FIRST_GC_LIMIT; int GC_free_space_divisor = 4; #endif -static intptr_t mem_real_use, mem_uncollectable_use; +static intptr_t mem_real_use, mem_uncollectable_use, mem_cumulative_use; static intptr_t sector_mem_use, sector_admin_mem_use, sector_free_mem_use; static intptr_t manage_mem_use, manage_real_mem_use; @@ -2230,11 +2230,14 @@ void GC_dump(void) FPRINTF(STDERR, "End Map\n"); } -long GC_get_memory_use() +size_t GC_get_memory_use() { - /* returns a `long' instead of `intptr_t' for compatibility - with the Boehm GC */ - return (long)mem_real_use; + return (size_t)mem_real_use; +} + +size_t GC_get_total_bytes() +{ + return (size_t)mem_cumulative_use; } void GC_end_stubborn_change(void *p) @@ -2504,6 +2507,7 @@ static void *do_malloc(SET_NO_BACKINFO else mem_use += size; mem_real_use += (size + sizeof(MemoryChunk)); + mem_cumulative_use += (size + sizeof(MemoryChunk)); num_chunks++; if (!low_plausible || (c->start < low_plausible)) @@ -2642,6 +2646,7 @@ static void *do_malloc(SET_NO_BACKINFO high_plausible = block->end; mem_real_use += SECTOR_SEGMENT_SIZE; + mem_cumulative_use += SECTOR_SEGMENT_SIZE; block_top: @@ -2950,6 +2955,7 @@ static void register_finalizer(void *p, void (*f)(void *p, void *data), if (!fn) { fn = (Finalizer *)malloc_managed(sizeof(Finalizer)); mem_real_use += sizeof(Finalizer); + mem_cumulative_use += sizeof(Finalizer); GC_fo_entries++; } diff --git a/racket/src/racket/sgc/sgc.h b/racket/src/racket/sgc/sgc.h index 888f5fd51b..ba58ceda46 100644 --- a/racket/src/racket/sgc/sgc.h +++ b/racket/src/racket/sgc/sgc.h @@ -35,7 +35,8 @@ SGC_EXTERN void *GC_base(void *); SGC_EXTERN void GC_dump(void); -SGC_EXTERN long GC_get_memory_use(); +SGC_EXTERN size_t GC_get_memory_use(); +SGC_EXTERN size_t GC_get_total_bytes(); SGC_EXTERN void GC_end_stubborn_change(void *); diff --git a/racket/src/racket/src/eval.c b/racket/src/racket/src/eval.c index 238e421167..50eb3befe2 100644 --- a/racket/src/racket/src/eval.c +++ b/racket/src/racket/src/eval.c @@ -2251,6 +2251,8 @@ scheme_case_lambda_execute(Scheme_Object *expr) int i, cnt; Scheme_Thread *p = scheme_current_thread; + DEBUG_COUNT_ALLOCATION(expr); + seqin = (Scheme_Case_Lambda *)expr; #ifdef MZ_USE_JIT @@ -2502,6 +2504,8 @@ scheme_make_closure(Scheme_Thread *p, Scheme_Object *code, int close) GC_CAN_IGNORE mzshort *map; int i; + DEBUG_COUNT_ALLOCATION(code); + data = (Scheme_Lambda *)code; #ifdef MZ_USE_JIT diff --git a/racket/src/racket/src/gen-jit-ts.rkt b/racket/src/racket/src/gen-jit-ts.rkt index 36bd02ef25..4de54e7a79 100644 --- a/racket/src/racket/src/gen-jit-ts.rkt +++ b/racket/src/racket/src/gen-jit-ts.rkt @@ -191,6 +191,7 @@ s_v iSi_s siS_v + Sii_s z_p si_s sis_v diff --git a/racket/src/racket/src/hash.c b/racket/src/racket/src/hash.c index d2300e82dc..833c2e7d1f 100644 --- a/racket/src/racket/src/hash.c +++ b/racket/src/racket/src/hash.c @@ -246,6 +246,8 @@ Scheme_Hash_Table *scheme_make_hash_table(int type) { Scheme_Hash_Table *table; + DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_hash_table_type)); + table = MALLOC_ONE_TAGGED(Scheme_Hash_Table); table->size = 0; @@ -640,6 +642,8 @@ Scheme_Hash_Table *scheme_clone_hash_table(Scheme_Hash_Table *ht) Scheme_Hash_Table *table; Scheme_Object **ba; + DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_hash_table_type)); + table = MALLOC_ONE_TAGGED(Scheme_Hash_Table); memcpy(table, ht, sizeof(Scheme_Hash_Table)); MZ_OPT_HASH_KEY(&(table->iso)) = 0; @@ -723,6 +727,8 @@ scheme_make_bucket_table (intptr_t size, int type) Scheme_Bucket_Table *table; size_t asize; + DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_bucket_table_type)); + table = MALLOC_ONE_TAGGED(Scheme_Bucket_Table); table->size = 4; @@ -1119,6 +1125,8 @@ Scheme_Bucket_Table *scheme_clone_bucket_table(Scheme_Bucket_Table *bt) Scheme_Bucket_Table *table; size_t asize; + DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_bucket_table_type)); + table = MALLOC_ONE_TAGGED(Scheme_Bucket_Table); table->so.type = scheme_bucket_table_type; table->size = bt->size; @@ -2562,6 +2570,7 @@ XFORM_NONGCING static Scheme_Hash_Tree *hamt_assoc(Scheme_Hash_Tree *ht, uintptr static Scheme_Hash_Tree *hamt_alloc(int kind, int popcount) /* be sure to set `bitmap` field before a GC becomes possible */ { + DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_hash_tree_type)); return (Scheme_Hash_Tree *)scheme_malloc_small_tagged(HASH_TREE_RECORD_SIZE(kind, popcount)); } diff --git a/racket/src/racket/src/jit.h b/racket/src/racket/src/jit.h index 0905a52760..6487e0ae72 100644 --- a/racket/src/racket/src/jit.h +++ b/racket/src/racket/src/jit.h @@ -319,7 +319,7 @@ struct scheme_jit_common_record { void *flvector_ref_check_index_code[JIT_NUM_FL_KINDS]; void *flvector_set_check_index_code[JIT_NUM_FL_KINDS], *flvector_set_flonum_check_index_code[JIT_NUM_FL_KINDS]; void *fxvector_ref_code, *fxvector_ref_check_index_code, *fxvector_set_code, *fxvector_set_check_index_code; - void *struct_raw_ref_code, *struct_raw_set_code; + void *struct_raw_ref_code, *struct_raw_set_code, *struct_raw_refs_code; void *syntax_e_code; void *on_demand_jit_arity_code, *in_progress_on_demand_jit_arity_code; void *get_stack_pointer_code; diff --git a/racket/src/racket/src/jit_ts.c b/racket/src/racket/src/jit_ts.c index 733d3cfac1..10faf239fb 100644 --- a/racket/src/racket/src/jit_ts.c +++ b/racket/src/racket/src/jit_ts.c @@ -96,6 +96,7 @@ define_ts_ss_s(scheme_byte_string_eq_2, FSRC_MARKS) define_ts_s_s(scheme_unbox, FSRC_MARKS) define_ts_si_s(scheme_struct_ref, FSRC_MARKS) define_ts_sis_v(scheme_struct_set, FSRC_MARKS) +define_ts_Sii_s(unsafe_struct_refs, FSRC_MARKS) define_ts_iS_s(scheme_extract_checked_procedure, FSRC_MARKS) define_ts_iS_s(scheme_procedure_arity_includes, FSRC_MARKS) define_ts_ssi_s(vector_check_chaperone_of, FSRC_MARKS) @@ -219,6 +220,7 @@ define_ts_s_s(scheme_box, FSRC_OTHER) # define ts_scheme_byte_string_length scheme_byte_string_length # define ts_scheme_struct_ref scheme_struct_ref # define ts_scheme_struct_set scheme_struct_set +# define ts_unsafe_struct_refs unsafe_struct_refs # define ts_equal_as_bool equal_as_bool # define ts_scheme_string_eq_2 scheme_string_eq_2 # define ts_scheme_byte_string_eq_2 scheme_byte_string_eq_2 diff --git a/racket/src/racket/src/jit_ts_def.c b/racket/src/racket/src/jit_ts_def.c index 1ea6b65b66..ffe04270f1 100644 --- a/racket/src/racket/src/jit_ts_def.c +++ b/racket/src/racket/src/jit_ts_def.c @@ -187,59 +187,68 @@ static void ts_ ## id(Scheme_Object* g216, int g217, Scheme_Object** g218) \ else \ id(g216, g217, g218); \ } -#define define_ts_z_p(id, src_type) \ -static void* ts_ ## id(size_t g219) \ +#define define_ts_Sii_s(id, src_type) \ +static Scheme_Object* ts_ ## id(Scheme_Object** g219, int g220, int g221) \ XFORM_SKIP_PROC \ { \ if (scheme_use_rtcall) \ - return scheme_rtcall_z_p("[" #id "]", src_type, id, g219); \ + return scheme_rtcall_Sii_s("[" #id "]", src_type, id, g219, g220, g221); \ else \ - return id(g219); \ + return id(g219, g220, g221); \ +} +#define define_ts_z_p(id, src_type) \ +static void* ts_ ## id(size_t g222) \ + XFORM_SKIP_PROC \ +{ \ + if (scheme_use_rtcall) \ + return scheme_rtcall_z_p("[" #id "]", src_type, id, g222); \ + else \ + return id(g222); \ } #define define_ts_si_s(id, src_type) \ -static Scheme_Object* ts_ ## id(Scheme_Object* g220, int g221) \ +static Scheme_Object* ts_ ## id(Scheme_Object* g223, int g224) \ XFORM_SKIP_PROC \ { \ if (scheme_use_rtcall) \ - return scheme_rtcall_si_s("[" #id "]", src_type, id, g220, g221); \ + return scheme_rtcall_si_s("[" #id "]", src_type, id, g223, g224); \ else \ - return id(g220, g221); \ + return id(g223, g224); \ } #define define_ts_sis_v(id, src_type) \ -static void ts_ ## id(Scheme_Object* g222, int g223, Scheme_Object* g224) \ +static void ts_ ## id(Scheme_Object* g225, int g226, Scheme_Object* g227) \ XFORM_SKIP_PROC \ { \ if (scheme_use_rtcall) \ - scheme_rtcall_sis_v("[" #id "]", src_type, id, g222, g223, g224); \ + scheme_rtcall_sis_v("[" #id "]", src_type, id, g225, g226, g227); \ else \ - id(g222, g223, g224); \ + id(g225, g226, g227); \ } #define define_ts_ss_i(id, src_type) \ -static int ts_ ## id(Scheme_Object* g225, Scheme_Object* g226) \ +static int ts_ ## id(Scheme_Object* g228, Scheme_Object* g229) \ XFORM_SKIP_PROC \ { \ if (scheme_use_rtcall) \ - return scheme_rtcall_ss_i("[" #id "]", src_type, id, g225, g226); \ + return scheme_rtcall_ss_i("[" #id "]", src_type, id, g228, g229); \ else \ - return id(g225, g226); \ + return id(g228, g229); \ } #define define_ts_iSp_v(id, src_type) \ -static void ts_ ## id(int g227, Scheme_Object** g228, void* g229) \ +static void ts_ ## id(int g230, Scheme_Object** g231, void* g232) \ XFORM_SKIP_PROC \ { \ if (scheme_use_rtcall) \ - scheme_rtcall_iSp_v("[" #id "]", src_type, id, g227, g228, g229); \ + scheme_rtcall_iSp_v("[" #id "]", src_type, id, g230, g231, g232); \ else \ - id(g227, g228, g229); \ + id(g230, g231, g232); \ } #define define_ts_sss_s(id, src_type) \ -static Scheme_Object* ts_ ## id(Scheme_Object* g230, Scheme_Object* g231, Scheme_Object* g232) \ +static Scheme_Object* ts_ ## id(Scheme_Object* g233, Scheme_Object* g234, Scheme_Object* g235) \ XFORM_SKIP_PROC \ { \ if (scheme_use_rtcall) \ - return scheme_rtcall_sss_s("[" #id "]", src_type, id, g230, g231, g232); \ + return scheme_rtcall_sss_s("[" #id "]", src_type, id, g233, g234, g235); \ else \ - return id(g230, g231, g232); \ + return id(g233, g234, g235); \ } #define define_ts__v(id, src_type) \ static void ts_ ## id() \ @@ -251,11 +260,11 @@ static void ts_ ## id() \ id(); \ } #define define_ts_iS_v(id, src_type) \ -static void ts_ ## id(int g233, Scheme_Object** g234) \ +static void ts_ ## id(int g236, Scheme_Object** g237) \ XFORM_SKIP_PROC \ { \ if (scheme_use_rtcall) \ - scheme_rtcall_iS_v("[" #id "]", src_type, id, g233, g234); \ + scheme_rtcall_iS_v("[" #id "]", src_type, id, g236, g237); \ else \ - id(g233, g234); \ + id(g236, g237); \ } diff --git a/racket/src/racket/src/jit_ts_future_glue.c b/racket/src/racket/src/jit_ts_future_glue.c index 29998b59d7..f95e4778d1 100644 --- a/racket/src/racket/src/jit_ts_future_glue.c +++ b/racket/src/racket/src/jit_ts_future_glue.c @@ -1,4 +1,4 @@ - Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g235, int g236, Scheme_Object** g237) + Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g238, int g239, Scheme_Object** g240) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -13,9 +13,9 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_s0 = g235; - future->arg_i1 = g236; - future->arg_S2 = g237; + future->arg_s0 = g238; + future->arg_i1 = g239; + future->arg_S2 = g240; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -25,7 +25,7 @@ receive_special_result(future, retval, 1); return retval; } - Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g238, Scheme_Object** g239, Scheme_Object* g240) + Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g241, Scheme_Object** g242, Scheme_Object* g243) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -40,9 +40,9 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_i0 = g238; - future->arg_S1 = g239; - future->arg_s2 = g240; + future->arg_i0 = g241; + future->arg_S1 = g242; + future->arg_s2 = g243; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -52,7 +52,7 @@ receive_special_result(future, retval, 1); return retval; } - Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g241) + Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g244) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -67,8 +67,8 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_s0 = g241; - send_special_result(future, g241); + future->arg_s0 = g244; + send_special_result(future, g244); future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; future = fts->thread->current_ft; @@ -77,7 +77,7 @@ receive_special_result(future, retval, 1); return retval; } - Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Lambda* g242) + Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Lambda* g245) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -92,7 +92,7 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_n0 = g242; + future->arg_n0 = g245; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -127,7 +127,7 @@ receive_special_result(future, retval, 1); return retval; } - Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g243, Scheme_Object* g244) + Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g246, Scheme_Object* g247) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -142,8 +142,8 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_s0 = g243; - future->arg_s1 = g244; + future->arg_s0 = g246; + future->arg_s1 = g247; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -153,7 +153,7 @@ receive_special_result(future, retval, 1); return retval; } - Scheme_Object* scheme_rtcall_ssi_s(const char *who, int src_type, prim_ssi_s f, Scheme_Object* g245, Scheme_Object* g246, int g247) + Scheme_Object* scheme_rtcall_ssi_s(const char *who, int src_type, prim_ssi_s f, Scheme_Object* g248, Scheme_Object* g249, int g250) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -168,9 +168,9 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_s0 = g245; - future->arg_s1 = g246; - future->arg_i2 = g247; + future->arg_s0 = g248; + future->arg_s1 = g249; + future->arg_i2 = g250; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -180,7 +180,7 @@ receive_special_result(future, retval, 1); return retval; } - Scheme_Object* scheme_rtcall_tt_s(const char *who, int src_type, prim_tt_s f, const Scheme_Object* g248, const Scheme_Object* g249) + Scheme_Object* scheme_rtcall_tt_s(const char *who, int src_type, prim_tt_s f, const Scheme_Object* g251, const Scheme_Object* g252) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -195,8 +195,8 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_t0 = g248; - future->arg_t1 = g249; + future->arg_t0 = g251; + future->arg_t1 = g252; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -206,7 +206,7 @@ receive_special_result(future, retval, 1); return retval; } - MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g250, Scheme_Object* g251) + MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g253, Scheme_Object* g254) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -221,8 +221,8 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_s0 = g250; - future->arg_s1 = g251; + future->arg_s0 = g253; + future->arg_s1 = g254; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -232,7 +232,7 @@ return retval; } - Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g252, intptr_t g253) + Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g255, intptr_t g256) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -247,8 +247,8 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_S0 = g252; - future->arg_l1 = g253; + future->arg_S0 = g255; + future->arg_l1 = g256; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -258,7 +258,7 @@ receive_special_result(future, retval, 1); return retval; } - Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, intptr_t g254) + Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, intptr_t g257) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -273,7 +273,7 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_l0 = g254; + future->arg_l0 = g257; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -283,7 +283,7 @@ receive_special_result(future, retval, 1); return retval; } - void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g255, Scheme_Object* g256, int g257) + void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g258, Scheme_Object* g259, int g260) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -298,9 +298,9 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_b0 = g255; - future->arg_s1 = g256; - future->arg_i2 = g257; + future->arg_b0 = g258; + future->arg_s1 = g259; + future->arg_i2 = g260; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -310,7 +310,7 @@ } - void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g258, int g259, Scheme_Object** g260) + void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g261, int g262, Scheme_Object** g263) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -325,9 +325,9 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_i0 = g258; - future->arg_i1 = g259; - future->arg_S2 = g260; + future->arg_i0 = g261; + future->arg_i1 = g262; + future->arg_S2 = g263; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -337,7 +337,7 @@ } - void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g261, Scheme_Object* g262) + void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g264, Scheme_Object* g265) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -352,8 +352,8 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_s0 = g261; - future->arg_s1 = g262; + future->arg_s0 = g264; + future->arg_s1 = g265; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -363,7 +363,7 @@ } - void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g263) + void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g266) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -378,7 +378,7 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_b0 = g263; + future->arg_b0 = g266; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -388,7 +388,7 @@ } - Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g264, intptr_t g265) + Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g267, intptr_t g268) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -403,8 +403,8 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_s0 = g264; - future->arg_l1 = g265; + future->arg_s0 = g267; + future->arg_l1 = g268; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -414,7 +414,7 @@ receive_special_result(future, retval, 1); return retval; } - Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g266, Scheme_Object** g267) + Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g269, Scheme_Object** g270) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -429,8 +429,8 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_i0 = g266; - future->arg_S1 = g267; + future->arg_i0 = g269; + future->arg_S1 = g270; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -440,7 +440,7 @@ receive_special_result(future, retval, 1); return retval; } - Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g268) + Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g271) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -455,7 +455,7 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_S0 = g268; + future->arg_S0 = g271; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -465,7 +465,7 @@ receive_special_result(future, retval, 1); return retval; } - void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g269) + void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g272) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -480,8 +480,8 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_s0 = g269; - send_special_result(future, g269); + future->arg_s0 = g272; + send_special_result(future, g272); future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; future = fts->thread->current_ft; @@ -490,7 +490,7 @@ } - Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g270, Scheme_Object** g271, int g272) + Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g273, Scheme_Object** g274, int g275) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -505,9 +505,9 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_i0 = g270; - future->arg_S1 = g271; - future->arg_i2 = g272; + future->arg_i0 = g273; + future->arg_S1 = g274; + future->arg_i2 = g275; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -517,7 +517,7 @@ receive_special_result(future, retval, 1); return retval; } - void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g273, int g274, Scheme_Object** g275) + void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g276, int g277, Scheme_Object** g278) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -532,9 +532,9 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_s0 = g273; - future->arg_i1 = g274; - future->arg_S2 = g275; + future->arg_s0 = g276; + future->arg_i1 = g277; + future->arg_S2 = g278; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -544,7 +544,34 @@ } - void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g276) + Scheme_Object* scheme_rtcall_Sii_s(const char *who, int src_type, prim_Sii_s f, Scheme_Object** g279, int g280, int g281) + XFORM_SKIP_PROC +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future; + double tm; + Scheme_Object* retval; + + future = fts->thread->current_ft; + future->prim_protocol = SIG_Sii_s; + future->prim_func = f; + tm = get_future_timestamp(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; + future->arg_S0 = g279; + future->arg_i1 = g280; + future->arg_i2 = g281; + + future_do_runtimecall(fts, (void*)f, 0, 1, 0); + fts->thread = scheme_current_thread; + future = fts->thread->current_ft; + retval = future->retval_s; + future->retval_s = 0; + receive_special_result(future, retval, 1); + return retval; +} + void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g282) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -559,7 +586,7 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_z0 = g276; + future->arg_z0 = g282; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -569,7 +596,7 @@ return retval; } - Scheme_Object* scheme_rtcall_si_s(const char *who, int src_type, prim_si_s f, Scheme_Object* g277, int g278) + Scheme_Object* scheme_rtcall_si_s(const char *who, int src_type, prim_si_s f, Scheme_Object* g283, int g284) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -584,8 +611,8 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_s0 = g277; - future->arg_i1 = g278; + future->arg_s0 = g283; + future->arg_i1 = g284; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -595,7 +622,7 @@ receive_special_result(future, retval, 1); return retval; } - void scheme_rtcall_sis_v(const char *who, int src_type, prim_sis_v f, Scheme_Object* g279, int g280, Scheme_Object* g281) + void scheme_rtcall_sis_v(const char *who, int src_type, prim_sis_v f, Scheme_Object* g285, int g286, Scheme_Object* g287) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -610,9 +637,9 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_s0 = g279; - future->arg_i1 = g280; - future->arg_s2 = g281; + future->arg_s0 = g285; + future->arg_i1 = g286; + future->arg_s2 = g287; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -622,7 +649,7 @@ } - int scheme_rtcall_ss_i(const char *who, int src_type, prim_ss_i f, Scheme_Object* g282, Scheme_Object* g283) + int scheme_rtcall_ss_i(const char *who, int src_type, prim_ss_i f, Scheme_Object* g288, Scheme_Object* g289) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -637,8 +664,8 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_s0 = g282; - future->arg_s1 = g283; + future->arg_s0 = g288; + future->arg_s1 = g289; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -648,7 +675,7 @@ return retval; } - void scheme_rtcall_iSp_v(const char *who, int src_type, prim_iSp_v f, int g284, Scheme_Object** g285, void* g286) + void scheme_rtcall_iSp_v(const char *who, int src_type, prim_iSp_v f, int g290, Scheme_Object** g291, void* g292) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -663,9 +690,9 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_i0 = g284; - future->arg_S1 = g285; - future->arg_p2 = g286; + future->arg_i0 = g290; + future->arg_S1 = g291; + future->arg_p2 = g292; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -675,7 +702,7 @@ } - Scheme_Object* scheme_rtcall_sss_s(const char *who, int src_type, prim_sss_s f, Scheme_Object* g287, Scheme_Object* g288, Scheme_Object* g289) + Scheme_Object* scheme_rtcall_sss_s(const char *who, int src_type, prim_sss_s f, Scheme_Object* g293, Scheme_Object* g294, Scheme_Object* g295) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -690,9 +717,9 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_s0 = g287; - future->arg_s1 = g288; - future->arg_s2 = g289; + future->arg_s0 = g293; + future->arg_s1 = g294; + future->arg_s2 = g295; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; @@ -727,7 +754,7 @@ } - void scheme_rtcall_iS_v(const char *who, int src_type, prim_iS_v f, int g290, Scheme_Object** g291) + void scheme_rtcall_iS_v(const char *who, int src_type, prim_iS_v f, int g296, Scheme_Object** g297) XFORM_SKIP_PROC { Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -742,8 +769,8 @@ future->time_of_request = tm; future->source_of_request = who; future->source_type = src_type; - future->arg_i0 = g290; - future->arg_S1 = g291; + future->arg_i0 = g296; + future->arg_S1 = g297; future_do_runtimecall(fts, (void*)f, 0, 1, 0); fts->thread = scheme_current_thread; diff --git a/racket/src/racket/src/jit_ts_protos.h b/racket/src/racket/src/jit_ts_protos.h index 1078efb1f0..bb96f2c95e 100644 --- a/racket/src/racket/src/jit_ts_protos.h +++ b/racket/src/racket/src/jit_ts_protos.h @@ -1,87 +1,90 @@ #define SIG_siS_s 11 typedef Scheme_Object* (*prim_siS_s)(Scheme_Object*, int, Scheme_Object**); -Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g349, int g350, Scheme_Object** g351); +Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g358, int g359, Scheme_Object** g360); #define SIG_iSs_s 12 typedef Scheme_Object* (*prim_iSs_s)(int, Scheme_Object**, Scheme_Object*); -Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g352, Scheme_Object** g353, Scheme_Object* g354); +Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g361, Scheme_Object** g362, Scheme_Object* g363); #define SIG_s_s 13 typedef Scheme_Object* (*prim_s_s)(Scheme_Object*); -Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g355); +Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g364); #define SIG_n_s 14 typedef Scheme_Object* (*prim_n_s)(Scheme_Native_Lambda*); -Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Lambda* g356); +Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Lambda* g365); #define SIG__s 15 typedef Scheme_Object* (*prim__s)(); Scheme_Object* scheme_rtcall__s(const char *who, int src_type, prim__s f ); #define SIG_ss_s 16 typedef Scheme_Object* (*prim_ss_s)(Scheme_Object*, Scheme_Object*); -Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g357, Scheme_Object* g358); +Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g366, Scheme_Object* g367); #define SIG_ssi_s 17 typedef Scheme_Object* (*prim_ssi_s)(Scheme_Object*, Scheme_Object*, int); -Scheme_Object* scheme_rtcall_ssi_s(const char *who, int src_type, prim_ssi_s f, Scheme_Object* g359, Scheme_Object* g360, int g361); +Scheme_Object* scheme_rtcall_ssi_s(const char *who, int src_type, prim_ssi_s f, Scheme_Object* g368, Scheme_Object* g369, int g370); #define SIG_tt_s 18 typedef Scheme_Object* (*prim_tt_s)(const Scheme_Object*, const Scheme_Object*); -Scheme_Object* scheme_rtcall_tt_s(const char *who, int src_type, prim_tt_s f, const Scheme_Object* g362, const Scheme_Object* g363); +Scheme_Object* scheme_rtcall_tt_s(const char *who, int src_type, prim_tt_s f, const Scheme_Object* g371, const Scheme_Object* g372); #define SIG_ss_m 19 typedef MZ_MARK_STACK_TYPE (*prim_ss_m)(Scheme_Object*, Scheme_Object*); -MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g364, Scheme_Object* g365); +MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g373, Scheme_Object* g374); #define SIG_Sl_s 20 typedef Scheme_Object* (*prim_Sl_s)(Scheme_Object**, intptr_t); -Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g366, intptr_t g367); +Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g375, intptr_t g376); #define SIG_l_s 21 typedef Scheme_Object* (*prim_l_s)(intptr_t); -Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, intptr_t g368); +Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, intptr_t g377); #define SIG_bsi_v 22 typedef void (*prim_bsi_v)(Scheme_Bucket*, Scheme_Object*, int); -void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g369, Scheme_Object* g370, int g371); +void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g378, Scheme_Object* g379, int g380); #define SIG_iiS_v 23 typedef void (*prim_iiS_v)(int, int, Scheme_Object**); -void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g372, int g373, Scheme_Object** g374); +void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g381, int g382, Scheme_Object** g383); #define SIG_ss_v 24 typedef void (*prim_ss_v)(Scheme_Object*, Scheme_Object*); -void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g375, Scheme_Object* g376); +void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g384, Scheme_Object* g385); #define SIG_b_v 25 typedef void (*prim_b_v)(Scheme_Bucket*); -void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g377); +void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g386); #define SIG_sl_s 26 typedef Scheme_Object* (*prim_sl_s)(Scheme_Object*, intptr_t); -Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g378, intptr_t g379); +Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g387, intptr_t g388); #define SIG_iS_s 27 typedef Scheme_Object* (*prim_iS_s)(int, Scheme_Object**); -Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g380, Scheme_Object** g381); +Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g389, Scheme_Object** g390); #define SIG_S_s 28 typedef Scheme_Object* (*prim_S_s)(Scheme_Object**); -Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g382); +Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g391); #define SIG_s_v 29 typedef void (*prim_s_v)(Scheme_Object*); -void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g383); +void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g392); #define SIG_iSi_s 30 typedef Scheme_Object* (*prim_iSi_s)(int, Scheme_Object**, int); -Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g384, Scheme_Object** g385, int g386); +Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g393, Scheme_Object** g394, int g395); #define SIG_siS_v 31 typedef void (*prim_siS_v)(Scheme_Object*, int, Scheme_Object**); -void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g387, int g388, Scheme_Object** g389); -#define SIG_z_p 32 +void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g396, int g397, Scheme_Object** g398); +#define SIG_Sii_s 32 +typedef Scheme_Object* (*prim_Sii_s)(Scheme_Object**, int, int); +Scheme_Object* scheme_rtcall_Sii_s(const char *who, int src_type, prim_Sii_s f, Scheme_Object** g399, int g400, int g401); +#define SIG_z_p 33 typedef void* (*prim_z_p)(size_t); -void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g390); -#define SIG_si_s 33 +void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g402); +#define SIG_si_s 34 typedef Scheme_Object* (*prim_si_s)(Scheme_Object*, int); -Scheme_Object* scheme_rtcall_si_s(const char *who, int src_type, prim_si_s f, Scheme_Object* g391, int g392); -#define SIG_sis_v 34 +Scheme_Object* scheme_rtcall_si_s(const char *who, int src_type, prim_si_s f, Scheme_Object* g403, int g404); +#define SIG_sis_v 35 typedef void (*prim_sis_v)(Scheme_Object*, int, Scheme_Object*); -void scheme_rtcall_sis_v(const char *who, int src_type, prim_sis_v f, Scheme_Object* g393, int g394, Scheme_Object* g395); -#define SIG_ss_i 35 +void scheme_rtcall_sis_v(const char *who, int src_type, prim_sis_v f, Scheme_Object* g405, int g406, Scheme_Object* g407); +#define SIG_ss_i 36 typedef int (*prim_ss_i)(Scheme_Object*, Scheme_Object*); -int scheme_rtcall_ss_i(const char *who, int src_type, prim_ss_i f, Scheme_Object* g396, Scheme_Object* g397); -#define SIG_iSp_v 36 +int scheme_rtcall_ss_i(const char *who, int src_type, prim_ss_i f, Scheme_Object* g408, Scheme_Object* g409); +#define SIG_iSp_v 37 typedef void (*prim_iSp_v)(int, Scheme_Object**, void*); -void scheme_rtcall_iSp_v(const char *who, int src_type, prim_iSp_v f, int g398, Scheme_Object** g399, void* g400); -#define SIG_sss_s 37 +void scheme_rtcall_iSp_v(const char *who, int src_type, prim_iSp_v f, int g410, Scheme_Object** g411, void* g412); +#define SIG_sss_s 38 typedef Scheme_Object* (*prim_sss_s)(Scheme_Object*, Scheme_Object*, Scheme_Object*); -Scheme_Object* scheme_rtcall_sss_s(const char *who, int src_type, prim_sss_s f, Scheme_Object* g401, Scheme_Object* g402, Scheme_Object* g403); -#define SIG__v 38 +Scheme_Object* scheme_rtcall_sss_s(const char *who, int src_type, prim_sss_s f, Scheme_Object* g413, Scheme_Object* g414, Scheme_Object* g415); +#define SIG__v 39 typedef void (*prim__v)(); void scheme_rtcall__v(const char *who, int src_type, prim__v f ); -#define SIG_iS_v 39 +#define SIG_iS_v 40 typedef void (*prim_iS_v)(int, Scheme_Object**); -void scheme_rtcall_iS_v(const char *who, int src_type, prim_iS_v f, int g404, Scheme_Object** g405); +void scheme_rtcall_iS_v(const char *who, int src_type, prim_iS_v f, int g416, Scheme_Object** g417); diff --git a/racket/src/racket/src/jit_ts_runtime_glue.c b/racket/src/racket/src/jit_ts_runtime_glue.c index 3f826b8039..5b7ceff16d 100644 --- a/racket/src/racket/src/jit_ts_runtime_glue.c +++ b/racket/src/racket/src/jit_ts_runtime_glue.c @@ -290,6 +290,20 @@ case SIG_siS_v: f(arg_s0, arg_i1, arg_S2); + break; + } +case SIG_Sii_s: + { + prim_Sii_s f = (prim_Sii_s)future->prim_func; + GC_CAN_IGNORE Scheme_Object* retval; + JIT_TS_LOCALIZE(Scheme_Object**, arg_S0); JIT_TS_LOCALIZE(int, arg_i1); JIT_TS_LOCALIZE(int, arg_i2); + + future->arg_S0 = NULL; + ADJUST_RS_ARG(future, arg_S0); + retval = + f(arg_S0, arg_i1, arg_i2); + future->retval_s = retval; + send_special_result(future, retval); break; } case SIG_z_p: diff --git a/racket/src/racket/src/jitcall.c b/racket/src/racket/src/jitcall.c index 7d01aa6f63..c8b6413d26 100644 --- a/racket/src/racket/src/jitcall.c +++ b/racket/src/racket/src/jitcall.c @@ -36,6 +36,11 @@ static int generate_argument_boxing(mz_jit_state *jitter, Scheme_Lambda *lam, Scheme_App_Rec *app, Scheme_Object **alt_rands); #endif +static int detect_unsafe_struct_refs(Scheme_Object *arg, Scheme_Object **alt_rands, Scheme_App_Rec *app, + int i, int num_rands, int shift); +static int generate_unsafe_struct_ref_sequence(mz_jit_state *jitter, Scheme_Object *arg, Scheme_Object *last_arg, + int count, int stack_pos); + int scheme_direct_call_count, scheme_indirect_call_count; struct jit_direct_arg { @@ -1783,7 +1788,7 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ If no_call is 2, then rator is not necssarily evaluated. If no_call is 1, then rator is left in V1 and arguments are on runstack. */ { - int i, offset, need_safety = 0, apply_to_list = 0; + int i, offset, need_safety = 0, apply_to_list = 0, num_unsafe_struct_refs; int direct_prim = 0, need_non_tail = 0, direct_native = 0, direct_self = 0, nontail_self = 0; Scheme_Native_Closure *inline_direct_native = NULL; int almost_inline_direct_native = 0; @@ -2113,10 +2118,26 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ need_safety = 0; } #ifdef USE_FLONUM_UNBOXING - if (direct_lam - && (SCHEME_LAMBDA_FLAGS(direct_lam) & LAMBDA_HAS_TYPED_ARGS) - && (CLOSURE_ARGUMENT_IS_FLONUM(direct_lam, i+args_already_in_place) - || CLOSURE_ARGUMENT_IS_EXTFLONUM(direct_lam, i+args_already_in_place))) { + if (direct_lam) + num_unsafe_struct_refs = 0; + else +#endif + num_unsafe_struct_refs = detect_unsafe_struct_refs(arg, alt_rands, app, i, num_rands, 1+args_already_in_place); + if (num_unsafe_struct_refs > 1) { + /* Found a sequence of `(unsafed-struct-ref id 'number)` with + sequential `number`s, so extract the whole group at once */ + v = (alt_rands + ? alt_rands[i+1+args_already_in_place+num_unsafe_struct_refs-1] + : app->args[i+1+args_already_in_place+num_unsafe_struct_refs-1]); + mz_rs_sync(); + generate_unsafe_struct_ref_sequence(jitter, arg, v, num_unsafe_struct_refs, i + offset); + CHECK_LIMIT(); + i += (num_unsafe_struct_refs - 1); +#ifdef USE_FLONUM_UNBOXING + } else if (direct_lam + && (SCHEME_LAMBDA_FLAGS(direct_lam) & LAMBDA_HAS_TYPED_ARGS) + && (CLOSURE_ARGUMENT_IS_FLONUM(direct_lam, i+args_already_in_place) + || CLOSURE_ARGUMENT_IS_EXTFLONUM(direct_lam, i+args_already_in_place))) { int directly; int extfl; extfl = CLOSURE_ARGUMENT_IS_EXTFLONUM(direct_lam, i+args_already_in_place); @@ -2149,13 +2170,12 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ } else { (void)jit_movi_p(JIT_R0, NULL); } - } else #endif - if (inline_direct_args) { - if (inline_direct_args[i].gen) + } else if (inline_direct_args) { + if (inline_direct_args[i].gen) scheme_generate(arg, jitter, 0, 0, 0, inline_direct_args[i].reg, NULL, NULL); - } else - scheme_generate_non_tail(arg, jitter, 0, !need_non_tail, 0); /* sync'd below */ + } else + scheme_generate_non_tail(arg, jitter, 0, !need_non_tail, 0); /* sync'd below */ RESUME_JIT_DATA(); CHECK_LIMIT(); @@ -2397,4 +2417,91 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ return is_tail ? 2 : 1; } + +static int detect_unsafe_struct_refs(Scheme_Object *arg, Scheme_Object **alt_rands, Scheme_App_Rec *app, + int i, int num_rands, int shift) +/* Look for `(unsafe-struct-ref id 'num)` ... as a sequence of + arguments, which shows up as a result of `struct-copy`, and return + the length of the sequence. Instead of performing each + `unsafe-struct-ref` separately, which involves a chaperone test + each time, we'll test once and extract all. */ +{ + Scheme_App3_Rec *app3, *next_app3; + Scheme_Object *next_arg; + + if (SAME_TYPE(SCHEME_TYPE(arg), scheme_application3_type)) { + app3 = (Scheme_App3_Rec *)arg; + if (SAME_OBJ(app3->rator, scheme_unsafe_struct_ref_proc) + && SAME_TYPE(SCHEME_TYPE(app3->rand1), scheme_local_type) + && SCHEME_INTP(app3->rand2)) { + int seq = 1, delta = SCHEME_INT_VAL(app3->rand2) - i; + i++; + while (i < num_rands) { + next_arg = (alt_rands ? alt_rands[i+shift] : app->args[i+shift]); + if (SAME_TYPE(SCHEME_TYPE(next_arg), scheme_application3_type)) { + next_app3 = (Scheme_App3_Rec *)next_arg; + if (SAME_OBJ(next_app3->rator, scheme_unsafe_struct_ref_proc) + && SAME_TYPE(SCHEME_TYPE(next_app3->rand1), scheme_local_type) + && SCHEME_INTP(next_app3->rand2) + && (SCHEME_INT_VAL(next_app3->rand2) == i + delta) + && (SCHEME_LOCAL_POS(next_app3->rand1) == SCHEME_LOCAL_POS(app3->rand1))) { + seq++; + i++; + } else + break; + } else + break; + } + return seq; + } + } + + return 0; +} + +static int generate_unsafe_struct_ref_sequence(mz_jit_state *jitter, Scheme_Object *arg, Scheme_Object *last_arg, + int count, int stack_pos) +/* Implement a sequence discovered by `detect_unsafe_struct_refs()`. */ +{ + Scheme_App3_Rec *app3 = (Scheme_App3_Rec *)arg; + int i, base = SCHEME_INT_VAL(app3->rand2); + GC_CAN_IGNORE jit_insn *ref, *refslow, *ref2; + + /* Using `last_arg` ensures that we clear the local, if needed */ + mz_runstack_skipped(jitter, 2); + scheme_generate(((Scheme_App3_Rec *)last_arg)->rand1, jitter, 0, 0, 0, JIT_R0, NULL, NULL); + CHECK_LIMIT(); + mz_runstack_unskipped(jitter, 2); + + /* Check for chaperones, and take slow path if found */ + __START_SHORT_JUMPS__(1); + jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type); + ref = jit_bnei_i(jit_forward(), JIT_R2, scheme_chaperone_type); + refslow = jit_get_ip(); + jit_addi_p(JIT_R1, JIT_RUNSTACK, WORDS_TO_BYTES(stack_pos)); + jit_str_p(JIT_R1, JIT_R0); + jit_movi_i(JIT_V1, base); + jit_movi_p(JIT_R0, count); + (void)jit_calli(sjc.struct_raw_refs_code); + ref2 = jit_jmpi(jit_forward()); + mz_patch_branch(ref); + (void)jit_beqi_i(refslow, JIT_R2, scheme_proc_chaperone_type); + CHECK_LIMIT(); + + /* This is the fast path: */ + for (i = 0; i < count; i++) { + jit_ldxi_p(JIT_R1, JIT_R0, (intptr_t)&(((Scheme_Structure *)0x0)->slots[i+base])); + if (i != count - 1) + mz_rs_stxi(stack_pos+i, JIT_R1); + else + jit_movr_p(JIT_R0, JIT_R1); + CHECK_LIMIT(); + } + + mz_patch_branch(ref2); + __END_SHORT_JUMPS__(1); + + return 1; +} + #endif diff --git a/racket/src/racket/src/jitcommon.c b/racket/src/racket/src/jitcommon.c index 11ca5ba8e8..ff88696c91 100644 --- a/racket/src/racket/src/jitcommon.c +++ b/racket/src/racket/src/jitcommon.c @@ -182,6 +182,21 @@ static void chaperone_set_mark() MZ_RUNSTACK[1] = SCHEME_CHAPERONE_VAL(MZ_RUNSTACK[1]); } +static Scheme_Object *unsafe_struct_refs(Scheme_Object **rs, int offset, int count) +{ + int i; + Scheme_Object *v, *s = rs[0]; + + for (i = 0; i < count; i++) { + v = scheme_struct_ref(s, offset + i); + if (i == count-1) + return v; + rs[i] = v; + } + + return NULL; +} + #define JITCOMMON_TS_PROCS #include "jit_ts.c" @@ -1824,6 +1839,29 @@ static int common4(mz_jit_state *jitter, void *_data) scheme_jit_register_sub_func(jitter, code, scheme_false); } + /* *** struct_raw_refs_code *** */ + /* R1 points into the runstack, *R1 is struct, R0 is + count >= 2, and V1 is a starting slot in the structure */ + { + void *code; + + code = jit_get_ip(); + + sjc.struct_raw_refs_code = code; + + mz_prolog(JIT_R2); + JIT_UPDATE_THREAD_RSPTR(); + jit_prepare(3); + jit_pusharg_p(JIT_R0); + jit_pusharg_p(JIT_V1); + jit_pusharg_p(JIT_R1); + (void)mz_finish_lwe(ts_unsafe_struct_refs, ref); + jit_retval(JIT_R0); + mz_epilog(JIT_R2); + + scheme_jit_register_sub_func(jitter, code, scheme_false); + } + /* *** syntax_e_code *** */ /* R0 is (potential) syntax object */ { diff --git a/racket/src/racket/src/list.c b/racket/src/racket/src/list.c index 479fbc3555..5631071137 100644 --- a/racket/src/racket/src/list.c +++ b/racket/src/racket/src/list.c @@ -1050,9 +1050,11 @@ scheme_init_unsafe_hash (Scheme_Env *env) Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr) { #ifdef MZ_PRECISE_GC + DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_pair_type)); return GC_malloc_pair(car, cdr); #else Scheme_Object *cons; + DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_pair_type)); cons = scheme_alloc_object(); cons->type = scheme_pair_type; SCHEME_CAR(cons) = car; @@ -1793,6 +1795,8 @@ Scheme_Object *scheme_box(Scheme_Object *v) { Scheme_Object *obj; + DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_box_type)); + obj = scheme_alloc_small_object(); obj->type = scheme_box_type; SCHEME_BOX_VAL(obj) = v; @@ -3646,12 +3650,14 @@ static Scheme_Object *eqv_hash_code(int argc, Scheme_Object *argv[]) Scheme_Object *scheme_make_weak_box(Scheme_Object *v) { #ifdef MZ_PRECISE_GC + DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_weak_box_type)); return (Scheme_Object *)GC_malloc_weak_box(v, NULL, 0, 0); #else Scheme_Small_Object *obj; + DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_weak_box_type)); + obj = MALLOC_ONE_TAGGED_WEAK(Scheme_Small_Object); - obj->iso.so.type = scheme_weak_box_type; obj->u.ptr_val = v; diff --git a/racket/src/racket/src/print.c b/racket/src/racket/src/print.c index f1ebf18ef0..add80b650b 100644 --- a/racket/src/racket/src/print.c +++ b/racket/src/racket/src/print.c @@ -2808,9 +2808,13 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, cannot_print(pp, notdisplay, obj, ht, compact); } else { print_utf8_string(pp, "#<", 0, 2); - print_string_in_angle(pp, scheme_symbol_val(((Scheme_Struct_Type *)obj)->name), - "struct-type:", - SCHEME_SYM_LEN(((Scheme_Struct_Type *)obj)->name)); + if (((Scheme_Struct_Type *)obj)->name) { + print_string_in_angle(pp, scheme_symbol_val(((Scheme_Struct_Type *)obj)->name), + "struct-type:", + SCHEME_SYM_LEN(((Scheme_Struct_Type *)obj)->name)); + } else { + print_utf8_string(pp, "struct-type", 0, 11); + } PRINTADDRESS(pp, obj); print_utf8_string(pp, ">", 0, 1); } @@ -2821,9 +2825,13 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, cannot_print(pp, notdisplay, obj, ht, compact); } else { print_utf8_string(pp, "#<", 0, 2); - print_string_in_angle(pp, scheme_symbol_val(((Scheme_Struct_Property *)obj)->name), - "struct-type-property:", - SCHEME_SYM_LEN(((Scheme_Struct_Property *)obj)->name)); + if (((Scheme_Struct_Property *)obj)->name) { + print_string_in_angle(pp, scheme_symbol_val(((Scheme_Struct_Property *)obj)->name), + "struct-type-property:", + SCHEME_SYM_LEN(((Scheme_Struct_Property *)obj)->name)); + } else { + print_utf8_string(pp, "struct-type-property", 0, 21); + } PRINTADDRESS(pp, obj); print_utf8_string(pp, ">", 0, 1); } diff --git a/racket/src/racket/src/salloc.c b/racket/src/racket/src/salloc.c index 3b8df7068f..9ca2938dd1 100644 --- a/racket/src/racket/src/salloc.c +++ b/racket/src/racket/src/salloc.c @@ -3288,3 +3288,92 @@ intptr_t scheme_count_envbox(Scheme_Object *root, Scheme_Hash_Table *ht) } #endif + +/**********************************************************************/ + +#if RECORD_ALLOCATION_COUNTS + +/* Allocation profiling --- prints allocated counts (not necessarily + still live) after every `NUM_ALLOCS_BEFORE_REPORT` structure and + closure allocations. Adjust that constant to match a test program. + Also, run with `racket -j` so that structure allocation is not + inlined, and don't use places. */ + +#define NUM_ALLOCS_BEFORE_REPORT 100000 + +static Scheme_Hash_Table *allocs; +static int alloc_count; +static int reporting; + +#include "../gc2/my_qsort.c" +typedef struct alloc_count_result { int pos; int count; } alloc_count_result; + +static int smaller_alloc_count(const void *a, const void *b) { + return ((alloc_count_result*)a)->count - ((alloc_count_result*)b)->count; +} + +void scheme_record_allocation(Scheme_Object *tag) +{ + Scheme_Object *c; + + if (reporting) + return; + + alloc_count++; + + if (!allocs) { + REGISTER_SO(allocs); + reporting++; + allocs = scheme_make_hash_table(SCHEME_hash_ptr); + --reporting; + } + + c = scheme_hash_get(allocs, tag); + if (!c) c = scheme_make_integer(0); + scheme_hash_set(allocs, tag, scheme_make_integer(SCHEME_INT_VAL(c)+1)); + + if (alloc_count == NUM_ALLOCS_BEFORE_REPORT) { + alloc_count_result *a; + int count = allocs->count; + int k = 0; + int i; + char *s; + + reporting++; + + a = MALLOC_N_ATOMIC(alloc_count_result, count); + printf("\n"); + for (i = allocs->size; i--; ) { + if (allocs->vals[i]) { + a[k].pos = i; + a[k].count = SCHEME_INT_VAL(allocs->vals[i]); + k++; + } + } + my_qsort(a, allocs->count, sizeof(alloc_count_result), smaller_alloc_count); + + for (i = 0; i < count; i++) { + tag = allocs->keys[a[i].pos]; + + if (SCHEME_INTP(tag)) { + s = scheme_get_type_name(SCHEME_INT_VAL(tag)); + } else { + if (SAME_TYPE(SCHEME_TYPE(tag), scheme_lambda_type) + && ((Scheme_Lambda *)tag)->name) + tag = ((Scheme_Lambda*)tag)->name; + else if (SAME_TYPE(SCHEME_TYPE(tag), scheme_case_lambda_sequence_type) + && ((Scheme_Case_Lambda *)tag)->name) + tag = ((Scheme_Case_Lambda*)tag)->name; + + s = scheme_write_to_string(tag, NULL); + } + + printf("%d %s\n", a[i].count, s); + } + + alloc_count = 0; + --reporting; + } +} + +#endif diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index ff9a115d8c..7fe1094ea5 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -4414,6 +4414,18 @@ void scheme_count_generic(Scheme_Object *o, intptr_t *s, intptr_t *e, Scheme_Has #endif #endif +/* See "salloc.c": */ +#ifndef RECORD_ALLOCATION_COUNTS +# define RECORD_ALLOCATION_COUNTS 0 +#endif + +#if RECORD_ALLOCATION_COUNTS +extern void scheme_record_allocation(Scheme_Object *key); +# define DEBUG_COUNT_ALLOCATION(x) scheme_record_allocation(x); +#else +# define DEBUG_COUNT_ALLOCATION(x) /* empty */ +#endif + /*========================================================================*/ /* miscellaneous */ /*========================================================================*/ diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index 086f6b9d48..b108ee85bc 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -2543,6 +2543,8 @@ scheme_make_struct_instance(Scheme_Object *_stype, int argc, Scheme_Object **arg stype = (Scheme_Struct_Type *)_stype; + DEBUG_COUNT_ALLOCATION((Scheme_Object *)stype); + c = stype->num_slots; inst = (Scheme_Structure *) scheme_malloc_tagged(sizeof(Scheme_Structure) @@ -2591,6 +2593,8 @@ Scheme_Object *scheme_make_blank_prefab_struct_instance(Scheme_Struct_Type *styp Scheme_Structure *inst; int c; + DEBUG_COUNT_ALLOCATION((Scheme_Object *)stype); + c = stype->num_slots; inst = (Scheme_Structure *) scheme_malloc_tagged(sizeof(Scheme_Structure) @@ -2625,6 +2629,8 @@ Scheme_Object *scheme_make_prefab_struct_instance(Scheme_Struct_Type *stype, Scheme_Structure *inst; int i, c; + DEBUG_COUNT_ALLOCATION((Scheme_Object *)stype); + c = stype->num_slots; inst = (Scheme_Structure *) scheme_malloc_tagged(sizeof(Scheme_Structure) @@ -2682,6 +2688,8 @@ make_simple_struct_instance(int argc, Scheme_Object **args, Scheme_Object *prim) Scheme_Struct_Type *stype = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(prim)[0]; int i, c; + DEBUG_COUNT_ALLOCATION((Scheme_Object *)stype); + c = stype->num_slots; inst = (Scheme_Structure *) scheme_malloc_tagged(sizeof(Scheme_Structure) diff --git a/racket/src/racket/src/syntax.c b/racket/src/racket/src/syntax.c index effc067233..4f5ae77180 100644 --- a/racket/src/racket/src/syntax.c +++ b/racket/src/racket/src/syntax.c @@ -465,6 +465,8 @@ Scheme_Object *scheme_make_stx(Scheme_Object *val, { Scheme_Stx *stx; + DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_stx_type)); + stx = MALLOC_ONE_TAGGED(Scheme_Stx); stx->iso.so.type = scheme_stx_type; STX_KEY(stx) = HAS_SUBSTX(val) ? STX_SUBSTX_FLAG : 0; diff --git a/racket/src/racket/src/thread.c b/racket/src/racket/src/thread.c index 37246c2774..f7bff363ca 100644 --- a/racket/src/racket/src/thread.c +++ b/racket/src/racket/src/thread.c @@ -178,6 +178,8 @@ THREAD_LOCAL_DECL(int scheme_did_gc_count); THREAD_LOCAL_DECL(static intptr_t process_time_at_swap); THREAD_LOCAL_DECL(static intptr_t max_gc_pre_used_bytes); +THREAD_LOCAL_DECL(static intptr_t num_major_garbage_collections); +THREAD_LOCAL_DECL(static intptr_t num_minor_garbage_collections); SHARED_OK static int init_load_on_demand = 1; SHARED_OK static int compiled_file_check = SCHEME_COMPILED_FILE_CHECK_MODIFY_SECONDS; @@ -244,6 +246,7 @@ THREAD_LOCAL_DECL(struct Scheme_GC_Pre_Post_Callback_Desc *gc_prepost_callback_d ROSYM static Scheme_Object *read_symbol, *write_symbol, *execute_symbol, *delete_symbol, *exists_symbol; ROSYM static Scheme_Object *client_symbol, *server_symbol; ROSYM static Scheme_Object *major_symbol, *minor_symbol, *incremental_symbol; +ROSYM static Scheme_Object *cumulative_symbol; ROSYM static Scheme_Object *initial_compiled_file_check_symbol; @@ -528,6 +531,9 @@ void scheme_init_thread(Scheme_Env *env) minor_symbol = scheme_intern_symbol("minor"); incremental_symbol = scheme_intern_symbol("incremental"); + REGISTER_SO(cumulative_symbol); + cumulative_symbol = scheme_intern_symbol("cumulative"); + GLOBAL_PRIM_W_ARITY("dump-memory-stats" , scheme_dump_gc_stats, 0, -1, env); GLOBAL_PRIM_W_ARITY("vector-set-performance-stats!", current_stats , 1, 2, env); @@ -734,6 +740,7 @@ static Scheme_Object *collect_garbage(int argc, Scheme_Object *argv[]) static Scheme_Object *current_memory_use(int argc, Scheme_Object *args[]) { Scheme_Object *arg = NULL; + int cumulative = 0; uintptr_t retval = 0; if (argc) { @@ -741,19 +748,30 @@ static Scheme_Object *current_memory_use(int argc, Scheme_Object *args[]) arg = args[0]; } else if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_custodian_type)) { arg = args[0]; + } else if (SAME_OBJ(args[0], cumulative_symbol)) { + cumulative = 1; + arg = NULL; } else { scheme_wrong_contract("current-memory-use", - "(or/c custodian? #f)", + "(or/c custodian? 'cumulative #f)", 0, argc, args); } } + if (cumulative) { #ifdef MZ_PRECISE_GC - retval = GC_get_memory_use(arg); + retval = GC_get_memory_ever_allocated(); #else - scheme_unused_object(arg); - retval = GC_get_memory_use(); + retval = GC_get_total_bytes(); #endif + } else { +#ifdef MZ_PRECISE_GC + retval = GC_get_memory_use(arg); +#else + scheme_unused_object(arg); + retval = GC_get_memory_use(); +#endif + } return scheme_make_integer_value_from_unsigned(retval); } @@ -9255,6 +9273,11 @@ static void inform_GC(int master_gc, int major_gc, int inc_gc, && (max_gc_pre_used_bytes >= 0)) max_gc_pre_used_bytes = pre_used; + if (major_gc) + num_major_garbage_collections++; + else + num_minor_garbage_collections++; + logger = scheme_get_gc_logger(); if (logger && scheme_log_level_p(logger, SCHEME_LOG_DEBUG)) { /* Don't use scheme_log(), because it wants to allocate a buffer @@ -9330,17 +9353,26 @@ static void log_peak_memory_use() if (max_gc_pre_used_bytes > 0) { logger = scheme_get_gc_logger(); if (logger && scheme_log_level_p(logger, SCHEME_LOG_DEBUG)) { - char buf[256], nums[128], *num, *num2; - intptr_t buflen; + char buf[256], nums[128], *num, *numt, *num2; + intptr_t buflen, allocated_bytes; +#ifdef MZ_PRECISE_GC + allocated_bytes = GC_get_memory_ever_allocated(); +#else + allocated_bytes = GC_get_total_bytes(); +#endif memset(nums, 0, sizeof(nums)); - num = gc_num(nums, max_gc_pre_used_bytes); + num = gc_num(nums, max_gc_pre_used_bytes); + numt = gc_num(nums, allocated_bytes); num2 = gc_unscaled_num(nums, scheme_total_gc_time); sprintf(buf, - "" PLACE_ID_FORMAT "atexit peak was %sK; total %sms", + "" PLACE_ID_FORMAT "atexit peak %sK; alloc %sK; major %d; minor %d; %sms", #ifdef MZ_USE_PLACES scheme_current_place_id, #endif num, + numt, + num_major_garbage_collections, + num_minor_garbage_collections, num2); buflen = strlen(buf); scheme_log_message(logger, SCHEME_LOG_DEBUG, buf, buflen, scheme_false); diff --git a/racket/src/racket/src/vector.c b/racket/src/racket/src/vector.c index 8c64867250..4fcd015ec5 100644 --- a/racket/src/racket/src/vector.c +++ b/racket/src/racket/src/vector.c @@ -287,6 +287,8 @@ scheme_make_vector (intptr_t size, Scheme_Object *fill) scheme_wrong_contract("make-vector", "exact-nonnegative-integer?", -1, 0, &vec); } + DEBUG_COUNT_ALLOCATION(scheme_make_integer(scheme_vector_type)); + if (size < 1024) { vec = (Scheme_Object *)scheme_malloc_tagged(VECTOR_BYTES(size)); } else {