From 6a96687838f993d26d0b86aeeef8d600521fc7a0 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 3 Oct 2013 18:07:51 -0400 Subject: [PATCH] Fix TR constructor detection. Was accidentally turning #%expression into #%plain-app in some cases. original commit: ba9873b0a062c2d6a64f8e5a8db3e6bd01a6a5c7 --- .../typed-racket/optimizer/hidden-costs.rkt | 8 +- .../marketplace-struct.rkt | 162 ++++++++++++++++++ .../struct-constructor.rkt | 5 +- 3 files changed, 170 insertions(+), 5 deletions(-) create mode 100644 pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/missed-optimizations/marketplace-struct.rkt diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/hidden-costs.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/hidden-costs.rkt index 5f88e395..220b245a 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/hidden-costs.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/hidden-costs.rkt @@ -16,6 +16,7 @@ ;; It only logs operations with hidden costs, for use by Optimization Coach. (define-syntax-class hidden-cost-log-expr #:commit + #:literal-sets (kernel-literals) ;; Log functions that access parameters implicitly (e.g. `display', which ;; accesses `current-output-port'). (pattern (#%plain-app op:hidden-port-parameter-function args:opt-expr ...) @@ -28,9 +29,12 @@ #:with opt #'(op args.opt ...)) ;; Log calls to struct constructors, so that OC can report those used in ;; hot loops. - (pattern (#%plain-app op:id args:opt-expr ...) + ;; Note: Sometimes constructors are wrapped in `#%expression', need to watch + ;; for that too. + (pattern (#%plain-app (~and op-part (~or op:id (#%expression op:id))) + args:opt-expr ...) #:when (let ([constructor-for (syntax-property #'op 'constructor-for)]) (or (and constructor-for (struct-constructor? constructor-for)) (struct-constructor? #'op))) #:do [(log-optimization-info "struct constructor" #'op)] - #:with opt #'(op args.opt ...))) + #:with opt #'(op-part args.opt ...))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/missed-optimizations/marketplace-struct.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/missed-optimizations/marketplace-struct.rkt new file mode 100644 index 00000000..b2f668b5 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/missed-optimizations/marketplace-struct.rkt @@ -0,0 +1,162 @@ +#;#; +#< (Transition State))) +(define-type (TrapK Event State) (Event -> (InterruptK State))) +(struct: (State) + transition ([state : State]) + #:transparent) +(define-type (Transition State) (transition State)) +(struct: role ([orientation : Orientation] + [interest-type : InterestType]) + #:transparent) +(define-type Role role) +(define-type Orientation (U 'publisher 'subscriber)) +(define-type (Constreeof X) (Rec CT (U X (Pairof CT CT) False Void Null))) +(struct: process-spec ([boot : (PID -> CoTransition)]) + #:transparent) +(define-type ProcessSpec process-spec) +(define-type InterestType (U 'participant 'observer 'everything)) +(define-type (Handler State) (TrapK EndpointEvent State)) +(define-type EndpointEvent (U PresenceEvent + AbsenceEvent + MessageEvent)) +(struct: presence-event ([role : Role]) #:transparent) +(struct: absence-event ([role : Role]) #:transparent) +(struct: message-event ([role : Role]) #:transparent) +(define-type PresenceEvent presence-event) +(define-type AbsenceEvent absence-event) +(define-type MessageEvent message-event) +(define-type CoTransition (All (Result) (All (State) (Transition State) -> Result) -> Result)) + + + +(struct: vm ([processes : (HashTable PID Process)] + [next-process-id : PID]) + #:transparent) + +(struct: (State) + process ([debug-name : Any] + [pid : PID] + [state : State] + [spawn-ks : (Listof (Pairof Integer (TrapK PID State)))] ;; hmm + [endpoints : (HashTable Any (endpoint State))] + [meta-endpoints : (HashTable Any (endpoint State))]) + #:transparent) + +(struct: (State) + endpoint ([id : eid] + [role : role] + [handler : (Handler State)]) + #:transparent) + +(struct: eid ([pid : PID] + [pre-eid : Any]) + #:transparent) + +(define-type Process (All (R) (CoProcess R) -> R)) +(define-type (CoProcess R) (All (State) (process State) -> R)) + +(: mkProcess : (All (State) ((CoProcess Process) State))) +;; A kind of identity function, taking the components of a process to +;; a process. +(define (mkProcess p) + (lambda (k) ((inst k State) p))) + +(: Process-pid : Process -> PID) +(define (Process-pid wp) ((inst wp PID) process-pid)) + +;; Unwraps a process. Result is the type of the result of the +;; expression; State is a type variable to be bound to the process's +;; private state type. p is to be bound to the unwrapped process; wp +;; is the expression producing the wrapped process. body... are the +;; forms computing a value of type Result. +(define-syntax-rule (unwrap-process State Result (p wp) body ...) + (let () + (: coproc : (All (State) (process State) -> Result)) + (define (coproc p) + body ...) + ((inst wp Result) coproc))) + +;;--------------------------------------------------------------------------- + +(: make-vm : process-spec -> vm) +(define (make-vm boot) + (define primordial (mkProcess ((inst process Void) + '#:primordial + -1 + (void) + (list) + #hash() + #hash()))) + (vm (hash-set (ann #hash() (HashTable PID Process)) + (Process-pid primordial) + primordial) + 0)) + +(: inject-process : vm Process -> vm) +(define (inject-process state wp) + (struct-copy vm state [processes (hash-set (vm-processes state) (Process-pid wp) wp)])) + +(: always-false : -> False) +(define (always-false) #f) + +(: extract-process : vm PID -> (values vm (Option Process))) +(define (extract-process state pid) + (define wp (hash-ref (vm-processes state) pid always-false)) + (values (if wp + (struct-copy vm state [processes (hash-remove (vm-processes state) pid)]) + state) + wp)) + +(: process-map : (All (State) (process State) -> (process State)) vm -> vm) +(define (process-map f state) + (for/fold ([state state]) ([pid (in-hash-keys (vm-processes state))]) + (let-values (((state wp) (extract-process state pid))) + (if (not wp) + state + (unwrap-process State vm (p wp) + (inject-process state (mkProcess (f p)))))))) + +(: endpoint-fold : (All (A) (All (State) (process State) (endpoint State) A -> A) A vm -> A)) +(define (endpoint-fold f seed state) + (for/fold ([seed seed]) ([pid (in-hash-keys (vm-processes state))]) + (let-values (((state wp) (extract-process state pid))) + (if (not wp) + seed + (unwrap-process State A (p wp) + (for/fold ([seed seed]) ([pre-eid (in-hash-keys (process-endpoints p))]) + (define ep (hash-ref (process-endpoints p) pre-eid)) + ((inst f State) p ep seed))))))) + +;;; Local Variables: +;;; eval: (put 'unwrap-process 'scheme-indent-function 3) +;;; End: diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/missed-optimizations/struct-constructor.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/missed-optimizations/struct-constructor.rkt index 9945db3f..36b25ddd 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/missed-optimizations/struct-constructor.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/missed-optimizations/struct-constructor.rkt @@ -1,9 +1,8 @@ #;#; #<