From 3c0b79950336bd8abfc87d5c29560eec33e68ff2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 17 Jul 2013 17:48:32 -0600 Subject: [PATCH] clean up places benchmark compilation --- .../benchmarks/places/place-channel.rkt | 31 +++++++----- .../benchmarks/places/place-processes.rkt | 47 +++++++------------ .../racket/benchmarks/places/place-utils.rkt | 34 +++++--------- 3 files changed, 49 insertions(+), 63 deletions(-) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/places/place-channel.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/places/place-channel.rkt index 9fd3cfa0b1..e23bdeeade 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/places/place-channel.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/places/place-channel.rkt @@ -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)]) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/places/place-processes.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/places/place-processes.rkt index 00ff5a08d5..33d53b1a81 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/places/place-processes.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/places/place-processes.rkt @@ -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 () diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/places/place-utils.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/places/place-utils.rkt index 230856bc42..288ba74a8b 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/places/place-utils.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/benchmarks/places/place-utils.rkt @@ -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 ()