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

clean up places benchmark compilation

Browse Source
This commit is contained in:
Matthew Flatt 2013-07-17 17:48:32 -06:00
parent 7a8b2e333b
commit 3c0b799503
3 changed files with 49 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/places/place-channel.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
;; stress tests for place-channels
(require (prefix-in pp: "place-processes.rkt"))
(require (prefix-in pp: "place-processes.rkt")
(prefix-in pu: "place-utils.rkt"))
(require racket/place
racket/path
racket/system)
@ -17,16 +18,18 @@
(exact->inexact (/ B/sE (* 1024 1024)))
'MB-per-second)))
(define (processes-byte-message-test)
(let ([pl (pp:place/base
(bo ch)
(define message-size (* 4024 1024))
(define count 10)
(define fourk-b-message (make-bytes message-size 66))
(for ([i (in-range count)])
(place-channel-get ch)
(place-channel-put ch fourk-b-message)))])
(pp:place/base
byte-message
(bo ch)
(define message-size (* 4024 1024))
(define count 10)
(define fourk-b-message (make-bytes message-size 66))
(for ([i (in-range count)])
(place-channel-get ch)
(place-channel-put ch fourk-b-message)))
(define (processes-byte-message-test)
(let ([pl (pp:dynamic-place (pu:here-submod byte-message) 'bo)])
(define message-size (* 4024 1024))
(define four-k-message (make-bytes message-size 65))
(define count 10)
@ -73,7 +76,9 @@ END
(print-out "places" (/ (* 2 count message-size) (/ t2 1000)))
(place-wait pl)))
(place-wait pl))
(delete-file "pct1.rkt"))
(define (cons-tree-test)
(splat
@ -108,7 +113,9 @@ END
(printf "cons-tree ~a ~a ~a ~a\n" t1 t2 t3 (exact->inexact (/ t2 1000)))
(print-out "cons-tree" (/ s (/ t2 1000)))
(place-wait pl)))
(place-wait pl))
(delete-file "pct1.rkt"))
(define (current-executable-path)
(parameterize ([current-directory (find-system-path 'orig-dir)])

47
pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/places/place-processes.rkt
View File

@ -54,7 +54,11 @@
[(path? name) (path->bytes name)]
[(string? name) (string->bytes/locale name)]
[(bytes? name) name]
[else (raise 'module->path "expects a path or string")]))
[(and (list? name)
(= 3 (length name))
(eq? (car name) 'submod))
`(submod ,(module-name->bytes (cadr name)) ,(caddr name))]
[else (error 'module->path "expects a path or string")]))
(define (current-executable-path)
(parameterize ([current-directory (find-system-path 'orig-dir)])
(find-executable-path (find-system-path 'exec-file) #f)))
@ -66,7 +70,12 @@
(find-system-path 'orig-dir))))))
(define worker-cmdline-list (list (current-executable-path) "-X" (path->string (current-collects-path)) "-e" "(eval(read))"))
(let-values ([(process-handle out in err) (apply subprocess #f #f (current-error-port) worker-cmdline-list)])
(send/msg `((dynamic-require (bytes->path ,(module-name->bytes module-name)) (quote ,func-name))) in)
(send/msg `((dynamic-require ,(let ([bstr (module-name->bytes module-name)])
(if (bytes? bstr)
`(bytes->path ,bstr)
`(list ',(car bstr) (bytes->path ,(cadr bstr)) ',(caddr bstr))))
(quote ,func-name)))
in)
(make-place-s (make-place-channel-s out in) process-handle err)))
;; kill a place
@ -107,35 +116,15 @@
(sub1 left-overs)
new-result)))]))
;; macro which lifts a place-worker body to module scope and provides it
;; (place/lambda (worker-name:identifier channel:identifier) body ...)
;; returns syntax that creates a place
(define-syntax (place/base stx)
(syntax-case stx ()
[(_ (name ch) body ...)
(begin
(define (splat txt fn)
(call-with-output-file fn #:exists 'replace
(lambda (out)
(write txt out))))
(define module-path-prefix (make-temporary-file "place-benchmark~a.rkt" #f (current-directory)))
(define-values (base file-name isdir) (split-path module-path-prefix))
(define worker-syntax
(with-syntax ([module-name (datum->syntax #'name (string->symbol (path->string (path-replace-suffix file-name ""))))])
#'(module module-name racket/base
(require "place-processes.rkt")
(provide name)
(define (name)
(let ([ch (place-child-channel)])
body ...)))))
(define module-path (path->string module-path-prefix))
(splat (syntax->datum worker-syntax) module-path)
(define place-syntax #`(dynamic-place #,module-path (quote name)))
;(write (syntax->datum place-syntax))
place-syntax)]))
[(_ module-name (name ch) body ...)
#'(module module-name racket/base
(require "place-processes.rkt")
(provide name)
(define (name)
(let ([ch (place-child-channel)])
body ...)))]))
(define-syntax (place/lambda stx)
(syntax-case stx ()

34
pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/places/place-utils.rkt
View File

@ -10,6 +10,7 @@
barrier
places-wait
place/base
here-submod
time-n)
@ -36,29 +37,18 @@
(define-syntax (place/base stx)
(syntax-case stx ()
[(_ (name ch) body ...)
(begin
(define (splat txt fn)
(call-with-output-file fn #:exists 'replace
(lambda (out)
(write txt out))))
[(_ module-name (name ch) body ...)
#'(module module-name racket/base
(require racket/place)
(provide name)
(define (name ch)
body ...))]))
(define module-path (make-temporary-file "place-worker-~a.rkt" #f))
(define-values (base file-name isdir) (split-path module-path))
(define worker-syntax
(with-syntax ([module-name (datum->syntax #'name (string->symbol (path->string (path-replace-suffix file-name ""))))])
#'(module module-name racket/base
(require racket/place)
(provide name)
(define (name ch)
body ...))))
(define module-path-str (path->string module-path))
(splat (syntax->datum worker-syntax) module-path-str)
(define place-syntax #`(dynamic-place #,module-path (quote name)))
;(write (syntax->datum place-syntax)) (newline)
place-syntax)]))
(define-syntax-rule (here-submod id)
`(submod ,(resolved-module-path-name
(variable-reference->resolved-module-path
(#%variable-reference)))
id))
(define-syntax (time-n stx)
(syntax-case stx ()