From 990f73e698341d30a47e4cf2c4e7a503a8e2eb17 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Mon, 24 Oct 2005 20:44:46 +0000 Subject: [PATCH] Changes to speed up expansion of compiled code svn: r1144 --- .../profj/libs/java/lang/Object-composite.ss | 114 ++------------- collects/profj/to-scheme.ss | 135 ++++++++++++------ collects/profj/tool.ss | 24 ++-- 3 files changed, 110 insertions(+), 163 deletions(-) diff --git a/collects/profj/libs/java/lang/Object-composite.ss b/collects/profj/libs/java/lang/Object-composite.ss index 81c73b506c..f35b80ec2a 100644 --- a/collects/profj/libs/java/lang/Object-composite.ss +++ b/collects/profj/libs/java/lang/Object-composite.ss @@ -1,4 +1,3 @@ -#cs (module Object-composite mzscheme (require (lib "class.ss") @@ -935,9 +934,11 @@ (make-object convert-assert-Throwable obj p n s c)) (define convert-assert-Throwable - (class object% - + (class convert-assert-Object + (init w p n s c) + (super-instantiate (w p n s c)) + (define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null)) (set! wrapped w) (set! pos-blame p) @@ -977,55 +978,16 @@ (define/public (printStackTrace-PrintStream printStream) (send wrapped printStackTrace-PrintStream)) (define/public (printStackTrace-PrintWriter pW) (send wrapped printStackTrace-PrintWriter)) (define/public (fillInStackTrace) (send wrapped fillInStackTrace)) - (define/public (clone) (send wrapped clone)) - (define/public (equals-java.lang.Object obj) - (let ((val (send wrapped equals-java.lang.Object - (make-object guard-convert-Object obj pos-blame neg-blame src cc-marks)))) - (unless (boolean? val) - (raise (make-exn:fail - (string->immutable-string - (format "~a broke ~a contract here; Throwable's equals expects boolean return, given ~a" - pos-blame neg-blame val)) cc-marks))) - val)) - - (define/public (finalize) (send wrapped finalize)) - (define/public (getClass) (send wrapped getClass)) - - (define/public (hashCode) - (let ((val (send wrapped hashCode))) - (unless (integer? val) - (raise (make-exn:fail - (string->immutable-string - (format "~a broke ~a contract here; Throwable's hashCode expects int return, given ~a" - pos-blame neg-blame val)) cc-marks))) - val)) - - (define/public (notify) (send wrapped notify)) - (define/public (notifyAll) (send wrapped notifyAll)) - (define/public (toString) - (let ((val (send wrapped toString))) - (unless (string? val) - (raise (make-exn:fail - (string->immutable-string - (format "~a broke ~a contract here: Throwable's toString expects String return, given ~a" - pos-blame neg-blame val)) cc-marks))) - (make-java-string val))) - (define/public (wait) (send wrapped wait)) - (define/public (wait-long l) (send wrapped wait-long l)) - (define/public (wait-long-int l i) (send wrapped wait-long l i)) - (define/public (my-name) (send wrapped my-name)) - (define/public (field-names) (send wrapped field-names)) - (define/public (field-values) (send wrapped field-values)) - (define/public (fields-for-display) (send wrapped fields-for-display)) - (super-instantiate ()))) + )) (define dynamic-Throwable/c (c:flat-named-contract "Throwable" (lambda (v) (is-a? v convert-assert-Throwable)))) (define guard-convert-Throwable - (class object% - + (class guard-convert-Object + (init w p n s c) + (super-instantiate (w p n s c)) (define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null)) (set! wrapped w) (set! pos-blame p) @@ -1071,66 +1033,6 @@ (define/public (fillInStackTrace) (send wrapped fillInStackTrace)) (define/public (fill-in-stack-trace) (send wrapped fillInStackTrace)) - (define/public (clone) (send wrapped clone)) - (define/public (equals-java.lang.Object . obj) - (unless (= (length obj) 1) - (raise (make-exn:fail:contract:arity - (string->immutable-string - (format "~a broke ~a contract here: Throwable's equals expects to be called with 1 argument, given ~n" - pos-blame neg-blame (length obj))) cc-marks))) - (send wrapped equals-java.lang.Object (wrap-convert-assert-Object (car obj) pos-blame neg-blame src cc-marks))) - (define/public (equals . obj) - (unless (= (length obj) 1) - (raise (make-exn:fail:contract:arity - (string->immutable-string - (format "~a broke ~a contract here: Throwable's equals expects to be called with 1 argument, given ~n" - pos-blame neg-blame (length obj))) cc-marks))) - (send wrapped equals-java.lang.Object (wrap-convert-assert-Object (car obj) pos-blame neg-blame src cc-marks))) - (define/public (finalize) (send wrapped finalize)) - (define/public (getClass) (send wrapped getClass)) - (define/public (get-class) (send wrapped getClass)) - (define/public (hashCode) (send wrapped hashCode)) - (define/public (hash-code) (send wrapped hashCode)) - (define/public (notify) (send wrapped notify)) - (define/public (notifyAll) (send wrapped notifyAll)) - (define/public (notify-all) (send wrapped notifyAll)) - (define/public (my-name) (send wrapped my-name)) - (define/public (toString) - (send (send wrapped toString) get-mzscheme-string)) - (define/public (to-string) (send (send wrapped toString) get-mzscheme-string)) - (define/public (wait) (send wrapped wait)) - (define/public (wait-long . l) - (unless (= (length l) 1) - (raise (make-exn:fail:contract:arity - (string->immutable-string - (format "~a broke ~a contract here: Throwable's wait-long expects to be called with 1 argument, given ~n" - pos-blame neg-blame (length l))) cc-marks))) - (unless (integer? (car l)) - (raise (make-exn:fail - (string->immutable-string - (format "~a broke ~a contract here: Throwable's wait that takes a long argument expected long, given ~a" - pos-blame neg-blame (car l))) cc-marks))) - (send wrapped wait-long (car l))) - (define/public (wait-long-int . l) - (unless (= (length l) 2) - (raise (make-exn:fail:contract:arity - (string->immutable-string - (format "~a broke ~a contract here: Throwable's wait-long-int expects to be called with 2 arguments, given ~n" - pos-blame neg-blame (length l))) cc-marks))) - (unless (integer? (car l)) - (raise (make-exn:fail - (string->immutable-string - (format "~a broke ~a contract here: Throwable's wait-long-int expected long, given ~a" - pos-blame neg-blame (car l))) cc-marks))) - (unless (integer? (cadr l)) - (raise (make-exn:fail - (string->immutable-string - (format "~a broke ~a contract here: Throwable's wait-long-int expected int, given ~a" - pos-blame neg-blame (cadr l))) cc-marks))) - (send wrapped wait-long (car l) (cadr l))) - (define/public (field-names) (send wrapped field-names)) - (define/public (field-values) (send wrapped field-values)) - (define/public (fields-for-display) (send wrapped fields-for-display)) (super-instantiate ()))) (define static-Throwable/c diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index 7ac67cd3bf..9df43ddc27 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -626,7 +626,8 @@ (accesses-protected methods)) overridden-methods)) (dynamic-method-defs (generate-dyn-method-defs names-for-dynamic)) - (wrapper-classes (append (generate-wrappers (class-name) + (wrapper-classes (append (generate-wrappers (class-name) + (parent-name) (filter (lambda (m) (not (or (private? (method-record-modifiers m)) (static? (method-record-modifiers m))))) @@ -726,25 +727,28 @@ (accesses-protected methods) (accesses-private methods))) - ,@dynamic-method-defs + ;,@dynamic-method-defs (define/override (my-name) ,(class-name)) - (define/override (field-names) - (append (super field-names) - (list ,@(map (lambda (n) (id-string (field-name n))) - (append (accesses-public fields) - (accesses-package fields) - (accesses-protected fields) - (accesses-private fields)))))) - - (define/override (field-values) - (append (super field-values) - (list ,@(map (lambda (n) (build-identifier (build-var-name (id-string (field-name n))))) - (append (accesses-public fields) - (accesses-package fields) - (accesses-protected fields) - (accesses-private fields)))))) + ,@(let ((non-static-fields + (append (accesses-public fields) + (accesses-package fields) + (accesses-protected fields) + (accesses-private fields)))) + (if (null? non-static-fields) + null + `((define/override (field-names) + (append (super field-names) + (list ,@(map + (lambda (n) (id-string (field-name n))) + non-static-fields + )))) + (define/override (field-values) + (append (super field-values) + (list ,@(map + (lambda (n) (build-identifier (build-var-name (id-string (field-name n))))) + non-static-fields))))))) (define field-accessors ,(build-field-table create-get-name 'get fields)) (define field-setters ,(build-field-table create-set-name 'set fields)) @@ -758,6 +762,8 @@ )) + ,@wrapper-classes + ,@(create-generic-methods (append (accesses-public methods) (accesses-package methods) (accesses-protected methods) @@ -789,7 +795,7 @@ (initialize-src i) type-recs)) (members-static-init class-members)) - ,@wrapper-classes + ) #f))) @@ -817,16 +823,24 @@ (lambda (v) (is-a? v ,(build-identifier (string-append "guard-convert-" class-name)))))))) ;generate-wrappers: string (list method-record) (list field) -> (list sexp) - (define (generate-wrappers class-name methods fields) - (let* ((normal-methods (filter - (lambda (m) - (not (or (eq? (method-record-rtype m) 'ctor) - (method-record-override m)))) methods)) + (define (generate-wrappers class-name super-name methods fields) + (let* ((wrapped-methods + (filter + (lambda (m) + #;(printf "~a (~a : ~a ~a)~n" (method-record-name m) (method-record-class m) class-name + (method-record-override m)) + (and (not (eq? (method-record-rtype m) 'ctor)) + (equal? (car (method-record-class m)) class-name) + (not (method-record-override m)))) + methods)) + (add-ca + (lambda (name) (build-identifier (string-append "convert-assert-" name)))) + (add-gc + (lambda (name) (build-identifier (string-append "guard-convert-" name)))) (class-text - (lambda (name from-dynamic? extra-methods) + (lambda (name super-name from-dynamic? extra-methods) `(define ,name - (class object% - (super-new) + (class ,super-name (init w p n s c) (define-values (wrapped-obj pos-blame neg-blame src cc-marks) (values null null null null null)) (set! wrapped-obj w) @@ -834,26 +848,25 @@ (set! neg-blame n) (set! src s) (set! cc-marks c) + (super-instantiate (w p n s c)) ,(generate-wrapper-fields fields from-dynamic?) - ,@(generate-wrapper-methods (filter (lambda (m) (not (eq? (method-record-rtype m) 'ctor))) - normal-methods) #f from-dynamic?) + ,@(generate-wrapper-methods + (filter (lambda (m) (not (eq? (method-record-rtype m) 'ctor))) + wrapped-methods) #f from-dynamic?) ,@extra-methods - - (define/public (my-name) (send wrapped-obj my-name)) - (define/public (field-names) (send wrapped-obj field-names)) - (define/public (field-values) (send wrapped-obj field-values)) - (define/public (fields-for-display) (send wrapped-obj fields-for-display)) - )))) - (dynamic-callables (refine-method-list methods))) + (dynamic-callables (refine-method-list wrapped-methods))) (list `(define (,(build-identifier (string-append "wrap-convert-assert-" class-name)) obj p n s c) - (c:contract ,(methods->contract normal-methods) obj p n s) - (make-object ,(build-identifier (string-append "convert-assert-" class-name)) obj p n s c)) - (class-text (build-identifier (string-append "convert-assert-" class-name)) #t null) - (class-text (build-identifier (string-append "guard-convert-" class-name)) #f + (and ,@(map method->check/error + (filter (lambda (m) (not (eq? 'ctor (method-record-rtype m)))) methods))) + #;(c:contract ,(methods->contract (filter (lambda (m) (not (eq? 'ctor (method-record-rtype m)))) + methods)) obj p n s) + (make-object ,(add-ca class-name) obj p n s c)) + (class-text (add-ca class-name) (add-ca super-name) #t null) + (class-text (add-gc class-name) (add-gc super-name) #f (generate-wrapper-methods dynamic-callables #t #f))))) ;generate-wrapper-fields: (list field) boolean -> sexp @@ -914,6 +927,18 @@ (method-record-atypes m))) (c:-> ,@(map (lambda (a) 'c:any/c) (method-record-atypes m)) c:any/c))) methods))) + + ;method->check/error: method-record -> sexp + (define (method->check/error method) + (let* ((name (method-record-name method)) + (m-name (mangle-method-name name (method-record-atypes method))) + (num-args (length (method-record-atypes method)))) + `(or (object-method-arity-includes? obj + (quote ,(build-identifier m-name)) + ,num-args) + (raise (make-exn:fail + (format "~a broke the contract with ~a here, expected an object with a method ~a accepting ~a args" + n p ,name ,num-args) s))))) ;convert-value: sexp type boolean -> sexp (define (convert-value value type from-dynamic?) @@ -977,8 +1002,6 @@ ((and (ref-type? type) (equal? string-type type)) (assert-value value 'string from-dynamic? kind name)) (else value)))) - - ;Removes from the list all methods that are not callable from a dynamic context ;refine-method-list: (list method-record) -> (list method-record) @@ -1236,6 +1259,7 @@ ,@(make-method-names (members-method members) null))) ,@(create-static-fields static-field-names (members-field members)) ,@(append (generate-wrappers (class-name) + "Object" (class-record-methods (send type-recs get-class-record (list (class-name)))) null) @@ -1432,14 +1456,31 @@ null (let* ((field (car fields)) (class (build-identifier (class-name))) + (ca-class (build-identifier (string-append "convert-assert-" (class-name)))) (quote-name (build-identifier (build-var-name (id-string (field-name field))))) (getter (car names)) + (setter (cadr names)) (final (final? (map modifier-kind (field-modifiers field))))) - (append (cons (make-syntax #f `(define ,getter - (class-field-accessor ,class ,quote-name)) #f) + (append (cons (make-syntax #f + `(define ,getter + (let ((normal-get (class-field-accessor ,class ,quote-name)) + (dyn-get (class-field-accessor ,ca-class ,quote-name))) + (lambda (obj) + (if (is-a? obj ,class) + (normal-get obj) + (dyn-get obj))))) + #f) (if (not final) - (list (make-syntax #f `(define ,(cadr names) - (class-field-mutator ,class ,quote-name)) #f)) + (list + (make-syntax #f + `(define ,setter + (let ((normal-set (class-field-mutator ,class ,quote-name)) + (dyn-set (class-field-mutator ,ca-class ,quote-name))) + (lambda (obj val) + (if (is-a? obj ,class) + (normal-set obj val) + (dyn-set obj val))))) + #f)) null)) (create-field-accessors (if final (cdr names) (cddr names)) (cdr fields)))))) @@ -1468,9 +1509,9 @@ (getter (create-get-name s-name)) (setter (create-set-name s-name))) (append (list (make-syntax #f `(define/public (,getter my-val) ,name) (build-src (id-src (field-name field)))) - (make-syntax #f `(define/public (,setter m-obj my-val) (set! ,name my-val)) + (make-syntax #f `(define/public (,setter m-obj my-val) (set! ,name my-val)) (build-src (id-src (field-name field))))) - (create-private-setters/getters (cdr fields)))))) + (create-private-setters/getters (cdr fields)))))) ;make-static-fiel-names: (list field) -> (list string) (define (make-static-field-names fields) diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index eead3d55d2..a7d608715d 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -351,17 +351,20 @@ (datum->syntax-object #f `(parse-java-full-program ,(parse port name level)) #f))))))) (define/public (front-end/interaction port settings teachpack-cache) (mred? #t) - (let ([name (object-name port)]) + (let ([name (object-name port)] + [executed? #f]) (lambda () - (if (eof-object? (peek-char-or-special port)) + (if executed? #;(eof-object? (peek-char-or-special port)) eof - (syntax-as-top - (datum->syntax-object - #f - #;`(compile-interactions-helper ,(lambda (ast) (compile-interactions-ast ast name level execute-types)) - ,(parse-interactions port name level)) - `(parse-java-interactions ,(parse-interactions port name level) ,name) - #f)))))) + (begin + (set! executed? #t) + (syntax-as-top + (datum->syntax-object + #f + #;`(compile-interactions-helper ,(lambda (ast) (compile-interactions-ast ast name level execute-types)) + ,(parse-interactions port name level)) + `(parse-java-interactions ,(parse-interactions port name level) ,name) + #f))))))) ;process-extras: (list struct) type-record -> (list syntax) (define/private (process-extras extras type-recs) @@ -543,7 +546,8 @@ (else (add1 (total-length (cdr lst)))))) (define/public (render-value/format value settings port width) - (render-value value settings port)(newline port)) + (render-value value settings port) + (newline port)) (define/public (create-executable fn parent . args) (printf "create-exe called~n")