suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix TR constructor detection.

Browse Source 
Was accidentally turning #%expression into #%plain-app in some cases.

original commit: ba9873b0a062c2d6a64f8e5a8db3e6bd01a6a5c7
This commit is contained in:
Vincent St-Amour 2013-10-03 18:07:51 -04:00
parent 3405bbdfac
commit 6a96687838
3 changed files with 170 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/hidden-costs.rkt
View File

@ -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 ...)))

162
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/missed-optimizations/marketplace-struct.rkt Normal file
View File

@ -0,0 +1,162 @@
#;#;
#<<END
TR info: marketplace-struct.rkt 113:39 process -- struct constructor
TR info: marketplace-struct.rkt 120:3 vm -- struct constructor
TR info: marketplace-struct.rkt 62:9 vm -- struct constructor
TR info: marketplace-struct.rkt 62:9 vm -- struct constructor
TR opt: marketplace-struct.rkt 127:2 (struct-copy vm state (processes (hash-set (vm-processes state) (Process-pid wp) wp))) -- dead else branch
TR opt: marketplace-struct.rkt 127:2 (struct-copy vm state (processes (hash-set (vm-processes state) (Process-pid wp) wp))) -- struct ref
TR opt: marketplace-struct.rkt 127:45 (vm-processes state) -- struct ref
TR opt: marketplace-struct.rkt 134:23 (vm-processes state) -- struct ref
TR opt: marketplace-struct.rkt 135:10 (if wp (struct-copy vm state (processes (hash-remove (vm-processes state) pid))) state) -- dead else branch
TR opt: marketplace-struct.rkt 135:10 (if wp (struct-copy vm state (processes (hash-remove (vm-processes state) pid))) state) -- struct ref
TR opt: marketplace-struct.rkt 136:60 (vm-processes state) -- struct ref
TR opt: marketplace-struct.rkt 142:48 (vm-processes state) -- struct ref
TR opt: marketplace-struct.rkt 151:46 (vm-processes state) -- struct ref
TR opt: marketplace-struct.rkt 156:60 (process-endpoints p) -- struct ref
TR opt: marketplace-struct.rkt 156:60 (process-endpoints p) -- struct ref
TR opt: marketplace-struct.rkt 157:35 (process-endpoints p) -- struct ref
TR opt: marketplace-struct.rkt 157:35 (process-endpoints p) -- struct ref
TR opt: marketplace-struct.rkt 157:35 (process-endpoints p) -- struct ref
TR opt: marketplace-struct.rkt 157:35 (process-endpoints p) -- struct ref
END
""
#lang typed/racket/base
;; excerpt from marketplace
;; a struct constructor logging bug was causing this to fail
(require racket/match)
(define-type PID Number)
(define-type (InterruptK State) (State -> (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:

5
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/missed-optimizations/struct-constructor.rkt
View File

@ -1,9 +1,8 @@
#;#;
#<<END
TR info: struct-constructor.rkt 15:7 foo -- struct constructor
END
#<<END
TR info: struct-constructor.rkt 14:7 foo -- struct constructor
END
""
#lang typed/racket