From 22fd8f51cc2c3effe6fd1c63e597a8f6be7f5e43 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sat, 4 Nov 2006 20:46:52 +0000 Subject: [PATCH] Added tracing capabilities to mzscheme's class system. - class-internal.ss exports two versions (traced/untraced) of macros/functions - classidmap.ss provides expansion to both forms (traced/untraced) - class-traced.ss exports traced versions - class.ss (unchanged) exports untraced versions - class-events.ss contains hooks called by traced version Functionality will be used by tool to be released via PLaneT. svn: r4778 --- collects/mzlib/class-traced.ss | 59 ++ collects/mzlib/private/class-events.ss | 111 ++++ collects/mzlib/private/class-internal.ss | 739 ++++++++++++++--------- collects/mzlib/private/classidmap.ss | 123 ++-- 4 files changed, 713 insertions(+), 319 deletions(-) create mode 100644 collects/mzlib/class-traced.ss create mode 100644 collects/mzlib/private/class-events.ss diff --git a/collects/mzlib/class-traced.ss b/collects/mzlib/class-traced.ss new file mode 100644 index 0000000000..7cb78b6a4a --- /dev/null +++ b/collects/mzlib/class-traced.ss @@ -0,0 +1,59 @@ +(module class-traced mzscheme + + ;; All of the implementation is actually in private/class-internal.ss, + ;; which provides extra (private) functionality to contract.ss. + (require "private/class-internal.ss") + + (provide (rename class-traced class) + (rename class*-traced class*) + (rename class/derived-traced class/derived) + (rename define-serializable-class-traced define-serializable-class) + (rename define-serializable-class*-traced define-serializable-class*) + class? + (rename mixin-traced mixin) + interface interface? + object% object? externalizable<%> + object=? + (rename new-traced new) + (rename make-object-traced make-object) + (rename instantiate-traced instantiate) + (rename send-traced send) + (rename send/apply-traced send/apply) + (rename send*-traced send*) + (rename class-field-accessor-traced class-field-accessor) + (rename class-field-mutator-traced class-field-mutator) + (rename with-method-traced with-method) + (rename get-field-traced get-field) + (rename field-bound?-traced field-bound?) + (rename field-names-traced field-names) + private* public* pubment* + override* overment* + augride* augment* + public-final* override-final* augment-final* + define/private define/public define/pubment + define/override define/overment + define/augride define/augment + define/public-final define/override-final define/augment-final + define-local-member-name define-member-name member-name-key generate-member-key + (rename generic-traced generic) + (rename make-generic-traced make-generic) + (rename send-generic-traced send-generic) + (rename is-a?-traced is-a?) + subclass? implementation? interface-extension? + (rename object-interface-traced object-interface) + (rename object-info-traced object-info) + (rename object->vector-traced object->vector) + (rename object-method-arity-includes?-traced object-method-arity-includes?) + method-in-interface? interface->method-names class->interface class-info + (struct exn:fail:object ()) + make-primitive-class + + ;; "keywords": + private public override augment + pubment overment augride + public-final override-final augment-final + field init init-field + rename-super rename-inner inherit inherit-field + this super inner + super-make-object super-instantiate super-new + inspect)) diff --git a/collects/mzlib/private/class-events.ss b/collects/mzlib/private/class-events.ss new file mode 100644 index 0000000000..f08011d97e --- /dev/null +++ b/collects/mzlib/private/class-events.ss @@ -0,0 +1,111 @@ + +(module class-events mzscheme + + (require-for-syntax (lib "stxparam.ss")) + (require (lib "stxparam.ss")) + + (provide current-class-event-handler + define-traced + trace-begin + trace + initialize-call-event + finalize-call-event + new-event + inspect-event + set-event + get-event + ) + + (define current-class-event-handler + (make-parameter void)) + + ;; ---------------------------------------------------------------------- + ;; Definitions for traced vs untraced functions + ;; ---------------------------------------------------------------------- + + (define-syntax-parameter trace? #f) + + (define-syntax trace + (make-set!-transformer + (lambda (stx) + (raise-syntax-error + #f + "trace used outside a trace-begin" + stx)))) + + (define-syntax (trace-begin stx) + (syntax-case stx (trace) + [(form (trace expr) ...) + (raise-syntax-error + #f + "traced block has no non-trace code" + stx)] + [(form expr0 (trace expr) ...) + (if (syntax-parameter-value (syntax trace?)) + (syntax/loc stx (begin0 expr0 expr ...)) + (syntax expr0))] + [(form (trace expr) rest ...) + (if (syntax-parameter-value (syntax trace?)) + (syntax/loc stx (begin expr (form rest ...))) + (syntax/loc stx (form rest ...)))] + [(form expr rest ...) + (syntax/loc stx (begin expr (form rest ...)))])) + + (define-syntax (define-traced stx) + (syntax-case stx () + [(form (name . args) . body) + (syntax/loc stx (form name (lambda args . body)))] + [(form name body ...) + (with-syntax ([name-traced + (datum->syntax-object + (syntax name) + (string->symbol + (string-append + (symbol->string (syntax-e (syntax name))) + "-traced")) + (syntax name))]) + (syntax/loc stx + (begin + (define name + (syntax-parameterize ([trace? #f]) + body ...)) + (define name-traced + (syntax-parameterize ([trace? #t]) + body ...)))))])) + + (define current-class-event-stack + (make-parameter null)) + + (define (initialize-event event . args) + (current-class-event-stack + (cons + (apply (current-class-event-handler) event args) + (current-class-event-stack)))) + + (define (finalize-event event . args) + (let* ([stack (current-class-event-stack)] + [head (car stack)] + [tail (cdr stack)]) + (when (procedure? head) (apply head args)) + (current-class-event-stack tail))) + + (define (new-event class obj fields) + ((current-class-event-handler) 'new class obj fields)) + + (define (initialize-call-event obj method args) + (initialize-event 'call obj method args)) + + (define (finalize-call-event . returned) + (apply finalize-event 'call returned) + (apply values returned)) + + (define (inspect-event obj) + ((current-class-event-handler) 'inspect obj)) + + (define (set-event obj field value) + ((current-class-event-handler) 'set obj field value)) + + (define (get-event obj field) + ((current-class-event-handler) 'get obj field)) + + ) \ No newline at end of file diff --git a/collects/mzlib/private/class-internal.ss b/collects/mzlib/private/class-internal.ss index a6783f4471..abbc36bc64 100644 --- a/collects/mzlib/private/class-internal.ss +++ b/collects/mzlib/private/class-internal.ss @@ -3,6 +3,7 @@ (require (lib "list.ss") (lib "etc.ss") (lib "stxparam.ss") + "class-events.ss" "serialize-structs.ss") (require-for-syntax (lib "kerncase.ss" "syntax") (lib "stx.ss" "syntax") @@ -117,7 +118,8 @@ ;; class macros ;;-------------------------------------------------------------------- - (define-syntaxes (class* _class class/derived) + (define-syntaxes (class* _class class/derived + class*-traced class-traced class/derived-traced) (let () ;; Start with Helper functions @@ -393,7 +395,7 @@ ;; -------------------------------------------------------------------------------- ;; Start here: - (define (main stx super-expr deserialize-id-expr name-id interface-exprs defn-and-exprs) + (define (main stx trace-flag super-expr deserialize-id-expr name-id interface-exprs defn-and-exprs) (let-values ([(this-id) #'this-id] [(the-obj) (datum->syntax-object (quote-syntax here) (gensym 'self))] [(the-finder) (datum->syntax-object (quote-syntax here) (gensym 'find-self))]) @@ -1012,7 +1014,8 @@ ;; make-XXX-map is supplied by private/classidmap.ss (with-syntax ([the-obj the-obj] [the-finder the-finder] - [this-id this-id]) + [this-id this-id] + [trace-flag (if trace-flag (syntax #t) (syntax #f))]) (syntax ([(inherit-field-name ... local-field ... @@ -1023,7 +1026,8 @@ public-final-name ... pubment-name ...) (values - (make-field-map (quote-syntax the-finder) + (make-field-map trace-flag + (quote-syntax the-finder) (quote the-obj) (quote-syntax inherit-field-name) (quote-syntax inherit-field-name-localized) @@ -1031,7 +1035,8 @@ (quote-syntax inherit-field-mutator) '()) ... - (make-field-map (quote-syntax the-finder) + (make-field-map trace-flag + (quote-syntax the-finder) (quote the-obj) (quote-syntax local-field) (quote-syntax local-field-localized) @@ -1316,43 +1321,59 @@ ;; Not primitive: #f)))))))))))))))) + (define (core-class* trace-flag) + (lambda (stx) + (syntax-case stx () + [(_ super-expression (interface-expr ...) + defn-or-expr + ...) + (main stx trace-flag + #'super-expression + #f #f + (syntax->list #'(interface-expr ...)) + (syntax->list #'(defn-or-expr ...)))]))) + + (define (core-class trace-flag) + (lambda (stx) + (syntax-case stx () + [(_ super-expression + defn-or-expr + ...) + (main stx trace-flag + #'super-expression + #f #f + null + (syntax->list #'(defn-or-expr ...)))]))) + + (define (core-class/derived trace-flag) + (lambda (stx) + (syntax-case stx () + [(_ orig-stx + [name-id super-expression (interface-expr ...) deserialize-id-expr] + defn-or-expr + ...) + (main #'orig-stx trace-flag + #'super-expression + #'deserialize-id-expr + (and (syntax-e #'name-id) #'name-id) + (syntax->list #'(interface-expr ...)) + (syntax->list #'(defn-or-expr ...)))]))) + ;; The class* and class entry points: (values ;; class* - (lambda (stx) - (syntax-case stx () - [(_ super-expression (interface-expr ...) - defn-or-expr - ...) - (main stx - #'super-expression - #f #f - (syntax->list #'(interface-expr ...)) - (syntax->list #'(defn-or-expr ...)))])) + (core-class* #f) ;; class - (lambda (stx) - (syntax-case stx () - [(_ super-expression - defn-or-expr - ...) - (main stx - #'super-expression - #f #f - null - (syntax->list #'(defn-or-expr ...)))])) + (core-class #f) ;; class/derived - (lambda (stx) - (syntax-case stx () - [(_ orig-stx - [name-id super-expression (interface-expr ...) deserialize-id-expr] - defn-or-expr - ...) - (main #'orig-stx - #'super-expression - #'deserialize-id-expr - (and (syntax-e #'name-id) #'name-id) - (syntax->list #'(interface-expr ...)) - (syntax->list #'(defn-or-expr ...)))]))))) + (core-class/derived #f) + ;; class*-traced + (core-class* #t) + ;; class-traced + (core-class #t) + ;; class/derived-traced + (core-class/derived #t) + ))) (define-syntax (-define-serializable-class stx) (syntax-case stx () @@ -2326,35 +2347,56 @@ ;; instantiation ;;-------------------------------------------------------------------- - (define-syntax (new stx) - (syntax-case stx () - [(_ cls (id arg) ...) - (andmap identifier? (syntax->list (syntax (id ...)))) - (syntax/loc stx (instantiate cls () (id arg) ...))] - [(_ cls (id arg) ...) - (for-each (lambda (id) - (unless (identifier? id) - (raise-syntax-error 'new "expected identifier" stx id))) - (syntax->list (syntax (id ...))))] - [(_ cls pr ...) - (for-each - (lambda (pr) - (syntax-case pr () - [(x y) (void)] - [else (raise-syntax-error 'new "expected name and value binding" stx pr)])) - (syntax->list (syntax (pr ...))))])) + (define-syntaxes (new new-traced) + + (let* ([core-new + (lambda (instantiate-stx stx) + (syntax-case stx () + [(_ cls (id arg) ...) + (andmap identifier? (syntax->list (syntax (id ...)))) + (quasisyntax/loc stx + ((unsyntax instantiate-stx) cls () (id arg) ...))] + [(_ cls (id arg) ...) + (for-each (lambda (id) + (unless (identifier? id) + (raise-syntax-error 'new "expected identifier" stx id))) + (syntax->list (syntax (id ...))))] + [(_ cls pr ...) + (for-each + (lambda (pr) + (syntax-case pr () + [(x y) (void)] + [else (raise-syntax-error 'new "expected name and value binding" stx pr)])) + (syntax->list (syntax (pr ...))))]))]) + + (values + (lambda (stx) (core-new (syntax/loc stx instantiate) stx)) + (lambda (stx) (core-new (syntax/loc stx instantiate-traced) stx))))) (define make-object (lambda (class . args) (do-make-object class args null))) + + (define make-object-traced + (lambda (class . args) + (do-make-object-traced class args null))) - (define-syntax instantiate - (lambda (stx) - (syntax-case stx () - [(form class (arg ...) . x) - (with-syntax ([orig-stx stx]) - (syntax/loc stx - (-instantiate do-make-object orig-stx (class) (list arg ...) . x)))]))) + (define-syntaxes (instantiate instantiate-traced) + + (let* ([core-instantiate + (lambda (do-make-object-stx stx) + (syntax-case stx () + [(form class (arg ...) . x) + (with-syntax ([orig-stx stx]) + (quasisyntax/loc stx + (-instantiate (unsyntax do-make-object-stx) + orig-stx (class) (list arg ...) . x)))]))]) + + (values + (lambda (stx) + (core-instantiate (syntax/loc stx do-make-object) stx)) + (lambda (stx) + (core-instantiate (syntax/loc stx do-make-object-traced) stx))))) ;; Helper; used by instantiate and super-instantiate (define-syntax -instantiate @@ -2389,13 +2431,26 @@ kwarg)])) (syntax->list (syntax (kwarg ...))))]))) - (define (do-make-object class by-pos-args named-args) + (define (alist->sexp alist) + (map (lambda (pair) (list (car pair) (cdr pair))) alist)) + + (define-traced (do-make-object class by-pos-args named-args) (unless (class? class) (raise-type-error 'instantiate "class" class)) (let ([o ((class-make-object class))]) - ;; Initialize it: - (continue-make-object o class by-pos-args named-args #t) - o)) + (trace-begin + ;; Initialize it: + (trace (new-event class o (alist->sexp (get-field-alist o)))) + (trace (initialize-call-event + o (string->symbol "(constructor)") + (cons (alist->sexp named-args) by-pos-args))) + (continue-make-object o class by-pos-args named-args #t) + (trace (finalize-call-event o)) + o))) + + (define (get-field-alist obj) + (map (lambda (id) (cons id (get-field/proc id obj))) + (field-names obj))) (define (continue-make-object o c by-pos-args named-args explict-named-args?) (let ([by-pos-only? (not (class-init-args c))]) @@ -2554,58 +2609,80 @@ ;; methods and fields ;;-------------------------------------------------------------------- - (define-syntaxes (send send/apply) - (let ([mk - (lambda (flatten?) - (lambda (stx) - (syntax-case stx () - [(_ obj name . args) - (begin - (unless (identifier? (syntax name)) - (raise-syntax-error - #f - "method name is not an identifier" - stx - (syntax name))) - (with-syntax ([name (localize (syntax name))]) - (if flatten? - (if (stx-list? (syntax args)) - (syntax (let-values ([(mth unwrapped-this) - (find-method/who 'send obj `name)]) - (apply mth unwrapped-this . args))) - (raise-syntax-error - #f - "bad syntax (illegal use of `.')" - stx)) - (if (stx-list? (syntax args)) - (syntax/loc stx - (let-values ([(mth unwrapped-this) - (find-method/who 'send obj `name)]) - (mth unwrapped-this . args))) - (with-syntax ([args (flatten-args (syntax args))]) - (syntax/loc stx - (let-values ([(mth unwrapped-this) - (find-method/who 'send obj `name)]) - (apply mth unwrapped-this . args))))))))])))]) - (values (mk #f) (mk #t)))) + (define-syntaxes (send send/apply send-traced send/apply-traced) + (let () + + (define (do-method traced? stx form obj name args rest-arg?) + (with-syntax ([(sym method receiver) + (generate-temporaries (syntax (1 2 3)))]) + (quasisyntax/loc stx + (let*-values ([(sym) (quasiquote (unsyntax (localize name)))] + [(method receiver) + (find-method/who '(unsyntax form) + (unsyntax obj) + sym)]) + (unsyntax + (make-method-call + traced? + stx + (syntax/loc stx receiver) + (syntax/loc stx unwrap-object) + (syntax/loc stx method) + (syntax/loc stx sym) + args + rest-arg?)))))) + + (define (core-send traced? apply?) + (lambda (stx) + (syntax-case stx () + [(form obj name . args) + (identifier? (syntax name)) + (if (stx-list? (syntax args)) + ;; (send obj name arg ...) or (send/apply obj name arg ...) + (do-method traced? stx #'form #'obj #'name #'args apply?) + (if apply? + ;; (send/apply obj name arg ... . rest) + (raise-syntax-error + #f "bad syntax (illegal use of `.')" stx) + ;; (send obj name arg ... . rest) + (do-method traced? stx #'form #'obj #'name + (flatten-args #'args) #t)))] + [(form obj name . args) + (raise-syntax-error + #f "method name is not an identifier" stx #'name)]))) + + (values + ;; send + (core-send #f #f) + ;; send/apply + (core-send #f #t) + ;; send-traced + (core-send #t #f) + ;; send/apply-traced + (core-send #t #t)))) - (define-syntax send* - (lambda (stx) - (syntax-case stx () - [(_ obj s ...) - (with-syntax ([sends (map (lambda (s) - (syntax-case s () - [(meth . args) - (syntax/loc s (send o meth . args))] - [_else (raise-syntax-error - #f - "bad method call" - stx - s)])) - (syntax->list (syntax (s ...))))]) - (syntax/loc stx - (let ([o obj]) - . sends)))]))) + (define-syntaxes (send* send*-traced) + (let* ([core-send* + (lambda (traced?) + (lambda (stx) + (syntax-case stx () + [(form obj clause ...) + (quasisyntax/loc stx + (let* ([o obj]) + (unsyntax-splicing + (map + (lambda (clause-stx) + (syntax-case clause-stx () + [(meth . args) + (quasisyntax/loc stx + ((unsyntax (if traced? + (syntax/loc stx send-traced) + (syntax/loc stx send))) + o meth . args))] + [_ (raise-syntax-error + #f "bad method call" stx clause-stx)])) + (syntax->list (syntax (clause ...)))))))])))]) + (values (core-send* #f) (core-send* #t)))) ;; find-method/who : symbol[top-level-form/proc-name] ;; any[object] @@ -2663,7 +2740,7 @@ make-struct-field-mutator class-field-set! class name)) - (define-struct generic (applicable)) + (define-struct generic (name applicable)) ;; Internally, make-generic comes from the struct def. ;; Externally, make-generic is the following procedure. @@ -2676,6 +2753,7 @@ (unless (symbol? name) (raise-type-error 'make-generic "symbol" name)) (make-generic + name (if (interface? class) (let ([intf class]) (unless (method-in-interface? name intf) @@ -2713,21 +2791,32 @@ dynamic-generic)))))]) make-generic)) - (define-syntax send-generic - (lambda (stx) - (syntax-case stx () - [(_ obj generic . args) - (if (stx-list? (syntax args)) - (with-syntax ([call (syntax/loc stx - (((generic-applicable generic) this) this . args))]) - (syntax/loc stx (let ([this obj]) - call))) - (with-syntax ([args (flatten-args (syntax args))]) - (with-syntax ([call (syntax/loc stx - (apply ((generic-applicable generic) this) this . args))]) - (syntax (let ([this obj]) - call)))))]))) - + (define-syntaxes (send-generic send-generic-traced) + (let () + (define (core-send-generic traced?) + (lambda (stx) + (syntax-case stx () + [(_ object generic . args) + (let* ([args-stx (syntax args)] + [proper? (stx-list? args-stx)] + [flat-stx (if proper? args-stx (flatten-args args-stx))]) + (with-syntax ([(gen obj) + (generate-temporaries (syntax (generic object)))]) + (quasisyntax/loc stx + (let* ([obj object] + [gen generic]) + (unsyntax + (make-method-call + traced? + stx + (syntax obj) + (syntax/loc stx unwrap-object) + (syntax/loc stx ((generic-applicable gen) obj)) + (syntax/loc stx (generic-name gen)) + flat-stx + (not proper?)))))))]))) + (values (core-send-generic #f) (core-send-generic #t)))) + (define-syntaxes (class-field-accessor class-field-mutator generic/form) (let ([mk (lambda (make targets) @@ -2755,29 +2844,58 @@ (mk (quote-syntax make-class-field-mutator) "class") (mk (quote-syntax make-generic/proc) "class or interface")))) - (define-syntax (get-field stx) + (define-syntax (class-field-accessor-traced stx) (syntax-case stx () - [(_ name obj) - (identifier? (syntax name)) - (with-syntax ([localized (localize (syntax name))]) - (syntax (get-field/proc `localized obj)))] - [(_ name obj) - (raise-syntax-error 'get-field "expected a field name as first argument" stx (syntax name))])) + [(form class name) + (syntax/loc stx + (let* ([accessor (class-field-accessor class name)]) + (lambda (obj) + (begin0 (accessor obj) + (get-event obj 'name)))))])) + + (define-syntax (class-field-mutator-traced stx) + (syntax-case stx () + [(form class name) + (syntax/loc stx + (let* ([mutator (class-field-mutator class name)]) + (lambda (obj value) + (begin0 (mutator obj value) + (set-event obj 'name value)))))])) + + (define-syntaxes (get-field get-field-traced) + (let () + (define (core-get-field traced?) + (lambda (stx) + (syntax-case stx () + [(_ name obj) + (identifier? (syntax name)) + (with-syntax ([get (if traced? + (syntax get-field/proc-traced) + (syntax get-field/proc))] + [localized (localize (syntax name))]) + (syntax (get `localized obj)))] + [(_ name obj) + (raise-syntax-error + 'get-field "expected a field name as first argument" + stx (syntax name))]))) + (values (core-get-field #f) (core-get-field #t)))) - (define (get-field/proc id obj) + (define-traced (get-field/proc id obj) (unless (object? obj) (raise-mismatch-error 'get-field "expected an object, got " obj)) - (let loop ([obj obj]) - (let* ([cls (object-ref obj)] - [field-ht (class-field-ht cls)] - [index (hash-table-get - field-ht - id - #f)]) - (cond + (trace-begin + (trace (get-event obj id)) + (let loop ([obj obj]) + (let* ([cls (object-ref obj)] + [field-ht (class-field-ht cls)] + [index (hash-table-get + field-ht + id + #f)]) + (cond [index ((class-field-ref (car index)) obj (cdr index))] [(wrapper-object? obj) @@ -2786,122 +2904,150 @@ (raise-mismatch-error 'get-field (format "expected an object that has a field named ~s, got " id) - obj)])))) + obj)]))))) - (define-syntax (field-bound? stx) - (syntax-case stx () - [(_ name obj) - (identifier? (syntax name)) - (with-syntax ([localized (localize (syntax name))]) - (syntax (field-bound?/proc `localized obj)))] - [(_ name obj) - (raise-syntax-error 'field-bound? "expected a field name as first argument" stx (syntax name))])) + (define-syntaxes (field-bound? field-bound?-traced) + (let () + (define (core-field-bound? traced?) + (lambda (stx) + (syntax-case stx () + [(_ name obj) + (identifier? (syntax name)) + (with-syntax ([localized (localize (syntax name))] + [bound? (if traced? + (syntax field-bound?/proc-traced) + (syntax field-bound?/proc))]) + (syntax (bound? `localized obj)))] + [(_ name obj) + (raise-syntax-error + 'field-bound? "expected a field name as first argument" + stx (syntax name))]))) + (values (core-field-bound? #f) (core-field-bound? #t)))) - (define (field-bound?/proc id obj) + (define-traced (field-bound?/proc id obj) (unless (object? obj) (raise-mismatch-error 'field-bound? "expected an object, got " obj)) - (let loop ([obj obj]) - (let* ([cls (object-ref obj)] - [field-ht (class-field-ht cls)]) - (or (and (hash-table-get field-ht id #f) - #t) ;; ensure that only #t and #f leak out, not bindings in ht - (and (wrapper-object? obj) - (loop (wrapper-object-wrapped obj))))))) + (trace-begin + (trace (inspect-event obj)) + (let loop ([obj obj]) + (let* ([cls (object-ref obj)] + [field-ht (class-field-ht cls)]) + (or (and (hash-table-get field-ht id #f) + #t) ;; ensure that only #t and #f leak out, not bindings in ht + (and (wrapper-object? obj) + (loop (wrapper-object-wrapped obj)))))))) - (define (field-names obj) + (define-traced (field-names obj) (unless (object? obj) (raise-mismatch-error 'field-names "expected an object, got " obj)) - (let loop ([obj obj]) - (let* ([cls (object-ref obj)] - [field-ht (class-field-ht cls)] - [flds (filter interned? (hash-table-map field-ht (lambda (x y) x)))]) - (if (wrapper-object? obj) - (append flds (loop (wrapper-object-wrapped obj))) - flds)))) + (trace-begin + (trace (inspect-event obj)) + (let loop ([obj obj]) + (let* ([cls (object-ref obj)] + [field-ht (class-field-ht cls)] + [flds (filter interned? (hash-table-map field-ht (lambda (x y) x)))]) + (if (wrapper-object? obj) + (append flds (loop (wrapper-object-wrapped obj))) + flds))))) - (define-syntax with-method - (lambda (stx) - (syntax-case stx () - [(_ ([id (obj-expr name)] ...) body0 body1 ...) - (let ([ids (syntax->list (syntax (id ...)))] - [names (syntax->list (syntax (name ...)))]) - (for-each (lambda (id name) - (unless (identifier? id) - (raise-syntax-error #f - "not an identifier for binding" - stx - id)) - (unless (identifier? name) - (raise-syntax-error #f - "not an identifier for method name" - stx - name))) - ids names) - (with-syntax ([(method ...) (generate-temporaries ids)] - [(method-obj ...) (generate-temporaries ids)] - [(name ...) (map localize names)]) - (syntax/loc stx (let-values ([(method method-obj) - (let ([obj obj-expr]) - (find-method/who 'with-method obj `name))] - ...) - (letrec-syntaxes+values ([(id) (make-with-method-map - (quote-syntax set!) - (quote-syntax id) - (quote-syntax method) - (quote-syntax method-obj))] - ...) - () - body0 body1 ...)))))] - ;; Error cases: - [(_ (clause ...) . body) - (begin - (for-each (lambda (clause) - (syntax-case clause () - [(id (obj-expr name)) - (and (identifier? (syntax id)) - (identifier? (syntax name))) - 'ok] - [_else - (raise-syntax-error - #f - "binding clause is not of the form (identifier (object-expr method-identifier))" - stx - clause)])) - (syntax->list (syntax (clause ...)))) - ;; If we get here, the body must be bad - (if (stx-null? (syntax body)) - (raise-syntax-error - #f - "empty body" - stx) - (raise-syntax-error - #f - "bad syntax (illegal use of `.')" - stx)))] - [(_ x . rest) - (raise-syntax-error - #f - "not a binding sequence" - stx - (syntax x))]))) + (define-syntaxes (with-method with-method-traced) + (let () + (define (core-with-method traced?) + (lambda (stx) + (syntax-case stx () + [(_ ([id (obj-expr name)] ...) body0 body1 ...) + (let ([ids (syntax->list (syntax (id ...)))] + [names (syntax->list (syntax (name ...)))]) + (for-each (lambda (id name) + (unless (identifier? id) + (raise-syntax-error #f + "not an identifier for binding" + stx + id)) + (unless (identifier? name) + (raise-syntax-error #f + "not an identifier for method name" + stx + name))) + ids names) + (with-syntax ([(method ...) (generate-temporaries ids)] + [(method-obj ...) (generate-temporaries ids)] + [(name ...) (map localize names)] + [trace-flag (if traced? (syntax/loc stx #t) (syntax/loc stx #f))]) + (syntax/loc stx (let-values ([(method method-obj) + (let ([obj obj-expr]) + (find-method/who 'with-method obj `name))] + ...) + (letrec-syntaxes+values ([(id) (make-with-method-map + trace-flag + (quote-syntax set!) + (quote-syntax id) + (quote-syntax method) + (quote-syntax method-obj) + (syntax unwrap-object))] + ...) + () + body0 body1 ...)))))] + ;; Error cases: + [(_ (clause ...) . body) + (begin + (for-each (lambda (clause) + (syntax-case clause () + [(id (obj-expr name)) + (and (identifier? (syntax id)) + (identifier? (syntax name))) + 'ok] + [_else + (raise-syntax-error + #f + "binding clause is not of the form (identifier (object-expr method-identifier))" + stx + clause)])) + (syntax->list (syntax (clause ...)))) + ;; If we get here, the body must be bad + (if (stx-null? (syntax body)) + (raise-syntax-error + #f + "empty body" + stx) + (raise-syntax-error + #f + "bad syntax (illegal use of `.')" + stx)))] + [(_ x . rest) + (raise-syntax-error + #f + "not a binding sequence" + stx + (syntax x))]))) + + (values + ;; with-method + (core-with-method #f) + ;; with-method-traced + (core-with-method #t)))) + ;;-------------------------------------------------------------------- ;; class, interface, and object properties ;;-------------------------------------------------------------------- - (define (is-a? v c) - (cond - [(class? c) ((class-object? c) (unwrap-object v))] - [(interface? c) - (and (object? v) - (implementation? (object-ref (unwrap-object v)) c))] - [else (raise-type-error 'is-a? "class or interface" 1 v c)])) + (define-traced (is-a? v c) + (trace-begin + (trace (when (object? v) + (inspect-event v))) + (cond + [(class? c) ((class-object? c) (unwrap-object v))] + [(interface? c) + (and (object? v) + (implementation? (object-ref (unwrap-object v)) c))] + [else (raise-type-error 'is-a? "class or interface" 1 v c)]))) (define (subclass? v c) (unless (class? c) @@ -2911,12 +3057,14 @@ (and (<= p (class-pos v)) (eq? c (vector-ref (class-supers v) p)))))) - (define (object-interface o) + (define-traced (object-interface o) (unless (object? o) (raise-type-error 'object-interface "object" o)) - (class-self-interface (object-ref (unwrap-object o)))) + (trace-begin + (trace (inspect-event o)) + (class-self-interface (object-ref (unwrap-object o))))) - (define (object-method-arity-includes? o name cnt) + (define-traced (object-method-arity-includes? o name cnt) (unless (object? o) (raise-type-error 'object-method-arity-includes? "object" o)) (unless (symbol? name) @@ -2925,14 +3073,16 @@ (exact? cnt) (not (negative? cnt))) (raise-type-error 'object-method-arity-includes? "non-negative exact integer" cnt)) - (let loop ([o o]) - (let* ([c (object-ref o)] - [pos (hash-table-get (class-method-ht c) name #f)]) - (cond - [pos (procedure-arity-includes? (vector-ref (class-methods c) pos) - (add1 cnt))] - [(wrapper-object? o) (loop (wrapper-object-wrapped o))] - [else #f])))) + (trace-begin + (trace (inspect-event o)) + (let loop ([o o]) + (let* ([c (object-ref o)] + [pos (hash-table-get (class-method-ht c) name #f)]) + (cond + [pos (procedure-arity-includes? (vector-ref (class-methods c) pos) + (add1 cnt))] + [(wrapper-object? o) (loop (wrapper-object-wrapped o))] + [else #f]))))) (define (implementation? v i) (unless (interface? i) @@ -2968,17 +3118,19 @@ (apply list-immutable (filter interned? (interface-public-ids i)))) - (define (object-info o) + (define-traced (object-info o) (unless (object? o) (raise-type-error 'object-info "object" o)) - (let loop ([c (object-ref (unwrap-object o))] - [skipped? #f]) - (if (struct? ((class-insp-mk c))) - ;; current inspector can inspect this object - (values c skipped?) - (if (zero? (class-pos c)) - (values #f #t) - (loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t))))) + (trace-begin + (trace (inspect-event o)) + (let loop ([c (object-ref (unwrap-object o))] + [skipped? #f]) + (if (struct? ((class-insp-mk c))) + ;; current inspector can inspect this object + (values c skipped?) + (if (zero? (class-pos c)) + (values #f #t) + (loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t)))))) (define (class-info c) (unless (class? c) @@ -3000,20 +3152,23 @@ (loop (vector-ref (class-supers next) (sub1 (class-pos next))) #t))))) (raise-mismatch-error 'class-info "current inspector cannot inspect class: " c))) - (define object->vector + (define-traced object->vector (opt-lambda (in-o [opaque-v '...]) (unless (object? in-o) (raise-type-error 'object->vector "object" in-o)) - (let ([o (unwrap-object in-o)]) - (list->vector - (cons - (string->symbol (format "object:~a" (class-name (object-ref o)))) - (reverse - (let-values ([(c skipped?) (object-info o)]) - (let loop ([c c][skipped? skipped?]) - (cond + (trace-begin + (trace (inspect-event in-o)) + (let ([o (unwrap-object in-o)]) + (list->vector + (cons + (string->symbol (format "object:~a" (class-name (object-ref o)))) + (reverse + (let-values ([(c skipped?) (object-info o)]) + (let loop ([c c][skipped? skipped?]) + (cond [(not c) (if skipped? (list opaque-v) null)] - [else (let-values ([(name num-fields field-ids field-ref field-set next next-skipped?) + [else (let-values ([(name num-fields field-ids field-ref + field-set next next-skipped?) (class-info c)]) (let ([rest (loop next next-skipped?)] [here (let loop ([n num-fields]) @@ -3023,7 +3178,7 @@ (loop (sub1 n)))))]) (append (if skipped? (list opaque-v) null) here - rest)))]))))))))) + rest)))])))))))))) (define (object=? o1 o2) (unless (object? o1) @@ -3409,7 +3564,37 @@ (define externalizable<%> (_interface () externalize internalize)) - + + ;; Providing traced versions: + (provide class-traced + class*-traced + class/derived-traced + (rename define-serializable-class define-serializable-class-traced) + (rename define-serializable-class* define-serializable-class*-traced) + (rename mixin mixin-traced) + new-traced + make-object-traced + instantiate-traced + send-traced + send/apply-traced + send*-traced + class-field-accessor-traced + class-field-mutator-traced + with-method-traced + get-field-traced + field-bound?-traced + field-names-traced + (rename generic/form generic-traced) + (rename make-generic/proc make-generic-traced) + send-generic-traced + is-a?-traced + object-interface-traced + object-info-traced + object->vector-traced + object-method-arity-includes?-traced + ) + + ;; Providing normal functionality: (provide (protect make-wrapper-class wrapper-object-wrapped extract-vtable diff --git a/collects/mzlib/private/classidmap.ss b/collects/mzlib/private/classidmap.ss index 7e2721cebc..6ac138d9fa 100644 --- a/collects/mzlib/private/classidmap.ss +++ b/collects/mzlib/private/classidmap.ss @@ -1,6 +1,7 @@ (module classidmap mzscheme (require (lib "stx.ss" "syntax")) + (require-for-template mzscheme "class-events.ss") (define-values (struct:s!t make-s!t s!t? s!t-ref s!t-set!) (make-struct-type 'set!-transformer #f 2 0 #f null (current-inspector) 0)) @@ -24,13 +25,7 @@ ;; Check Syntax binding info: (define (binding from to stx) - stx - ;; This 'bound-in-source is no longer needed - #; - (syntax-property - stx - 'bound-in-source - (cons from (syntax-local-introduce to)))) + stx) (define (make-this-map orig-id the-finder the-obj) @@ -49,34 +44,42 @@ stx)] [id (find the-finder the-obj stx)]))))) - (define (make-field-map the-finder the-obj the-binder the-binder-localized field-accessor field-mutator field-pos/null) + (define (make-field-map trace-flag the-finder the-obj the-binder the-binder-localized + field-accessor field-mutator field-pos/null) (let ([set!-stx (datum->syntax-object the-finder 'set!)]) (mk-set!-trans the-binder-localized (lambda (stx) - (syntax-case stx () - [(set! id expr) - (module-identifier=? (syntax set!) set!-stx) - (binding - the-binder (syntax id) - (datum->syntax-object - the-finder - (list* field-mutator (find the-finder the-obj stx) (append field-pos/null (list (syntax expr)))) - stx))] - [(id . args) - (binding - the-binder (syntax id) - (datum->syntax-object - the-finder - (cons (list* field-accessor (find the-finder the-obj stx) field-pos/null) (syntax args)) - stx))] - [_else - (binding - the-binder stx - (datum->syntax-object - the-finder - (list* field-accessor (find the-finder the-obj stx) field-pos/null) - stx))]))))) + (with-syntax ([obj-expr (find the-finder the-obj stx)]) + (syntax-case stx () + [(set! id expr) + (module-identifier=? (syntax set!) set!-stx) + (with-syntax ([bindings (syntax/loc stx ([obj obj-expr] [value expr]))] + [trace (syntax/loc stx (set-event obj (quote id) value))] + [set (quasisyntax/loc stx + ((unsyntax field-mutator) + obj (unsyntax-splicing field-pos/null) value))]) + (if trace-flag + (syntax/loc stx (let* bindings trace set)) + (syntax/loc stx (let* bindings set))))] + [(id . args) + (with-syntax ([bindings (syntax/loc stx ([obj obj-expr]))] + [trace (syntax/loc stx (get-event obj (quote id)))] + [call (quasisyntax/loc stx + (((unsyntax field-accessor) + obj-expr (unsyntax-splicing field-pos/null)) . args))]) + (if trace-flag + (syntax/loc stx (let* bindings trace call)) + (syntax/loc stx (let* bindings call))))] + [id + (with-syntax ([bindings (syntax/loc stx ([obj obj-expr]))] + [trace (syntax/loc stx (get-event obj (quote id)))] + [get (quasisyntax/loc stx + ((unsyntax field-accessor) + obj-expr (unsyntax-splicing field-pos/null)))]) + (if trace-flag + (syntax/loc stx (let* bindings trace get)) + (syntax/loc stx (let* bindings get))))])))))) (define (make-method-map the-finder the-obj the-binder the-binder-localized method-accessor) (let ([set!-stx (datum->syntax-object the-finder 'set!)]) @@ -248,22 +251,31 @@ "cannot use superclass initialization form in a method" stx))) - (define (make-with-method-map set!-stx id-stx method-stx method-obj-stx) + (define (make-with-method-map trace-flag set!-stx id-stx + method-stx method-obj-stx unwrap-stx) (make-set!-transformer (lambda (stx) (syntax-case stx () [(set! id expr) - (module-identifier=? (syntax set!) set!-stx) + (and (identifier? (syntax id)) + (module-identifier=? (syntax set!) set!-stx)) (raise-syntax-error 'with-method "cannot mutate method" stx)] [(id . args) - (datum->syntax-object - set!-stx - (make-method-apply - method-stx - method-obj-stx - (syntax args)) - stx)] - [_else + (identifier? (syntax id)) + (let* ([args-stx (syntax args)] + [proper? (stx-list? args-stx)] + [flat-args-stx (if proper? args-stx (flatten-args args-stx))]) + (make-method-call + trace-flag + stx + method-obj-stx + unwrap-stx + method-stx + (syntax (quote id)) + flat-args-stx + (not proper?)))] + [id + (identifier? (syntax id)) (raise-syntax-error 'with-method "misuse of method (not in application)" @@ -307,12 +319,39 @@ (and (pair? ctx) (class-context? (car ctx)))) + (define (make-method-call traced? source-stx object-stx unwrap-stx + method-proc-stx method-name-stx args-stx rest-arg?) + + (define-syntax (qstx stx) + (syntax-case stx () + [(form body) (syntax/loc stx (quasisyntax/loc source-stx body))])) + + (with-syntax ([object object-stx] + [method method-proc-stx] + [app (if rest-arg? (qstx apply) (qstx #%app))] + [args args-stx]) + (if traced? + (with-syntax ([(mth obj) (generate-temporaries + (list object-stx method-proc-stx))] + [unwrap unwrap-stx] + [name method-name-stx] + [(arg ...) (qstx args)] + [(var ...) (generate-temporaries (qstx args))]) + (qstx (let ([mth method] + [obj object] + [var arg] ...) + (initialize-call-event + (unwrap obj) name (app list var ...)) + (call-with-values (lambda () (app mth obj var ...)) + finalize-call-event)))) + (qstx (app method object . args))))) + (provide (protect make-this-map make-field-map make-method-map make-direct-method-map make-rename-super-map make-rename-inner-map make-init-error-map make-init-redirect super-error-map make-with-method-map - flatten-args + flatten-args make-method-call make-private-name localize generate-super-call generate-inner-call generate-class-expand-context class-top-level-context?)))