From 6994edd9773959a10ce2b655bef9925712540d67 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 3 Aug 2008 06:28:25 +0000 Subject: [PATCH] * Revised lazy/force so it actually works: - `!!' now scans the same kind of data that `make-reader-graph' handles (except that hash-tables are not implemented) - this means no structs, no mpairs, and a bunch of other stuff - `!!!' is gone (lazy procedures are not wrapped) - dealing with multiple values moved into lazy/lazy.ss itself (and in the future everything will move in there) * Removed lazy/promise, and use scheme/promise instead. Also remove the docs for lazy/promise that were bogus (since scheme/promise *is* doing the same thing now). * Other adjustments to the docs. They should be considered incomplete now, and will need a major rewrite when the whole thing works again (multiple values things are just commented out for now). * Added a test macro and a quick test suite for lazy/promise. * The lazy tests are added to the nightly build tests svn: r11042 --- collects/lazy/force.ss | 163 +++++++++++---------- collects/lazy/lazy.scrbl | 125 +--------------- collects/lazy/lazy.ss | 35 ++++- collects/lazy/promise.ss | 258 --------------------------------- collects/tests/lazy/main.ss | 49 +++++++ collects/tests/lazy/testing.ss | 70 +++++++++ 6 files changed, 240 insertions(+), 460 deletions(-) delete mode 100644 collects/lazy/promise.ss create mode 100644 collects/tests/lazy/main.ss create mode 100644 collects/tests/lazy/testing.ss diff --git a/collects/lazy/force.ss b/collects/lazy/force.ss index 0cdf4b014b..06280dca71 100644 --- a/collects/lazy/force.ss +++ b/collects/lazy/force.ss @@ -1,77 +1,92 @@ -(module force "mz-without-promises.ss" - (require "promise.ss") - (provide (all-defined-except do-!!)) +#lang scheme/base - (define-syntax ~ (make-rename-transformer #'lazy)) - (define ! force) +(require scheme/promise (for-syntax scheme/base)) - (define (!! x) (do-!! x #f)) - ;; Similar to the above, but wrap procedure values too - (define (!!! x) (do-!! x #t)) - ;; Force just a top-level list structure, similar to the above. - ;; (todo: this and the next assumes no cycles.) - (define (!list x) - (let loop ([x x]) - (let ([x (! x)]) (when (mpair? x) (set-mcdr! x (loop (mcdr x)))) x))) - ;; Force a top-level list structure and the first level of values, again, - ;; similar to the above. - (define (!!list x) - (let loop ([x x]) - (let ([x (! x)]) - (when (mpair? x) - (set-mcar! x (! (mcar x))) - (set-mcdr! x (loop (mcdr x)))) x))) - ;; Force and split resulting values. - (define (!values x) - (split-values (! x))) - ;; Similar, but forces the actual values too. - (define (!!values x) +(provide (all-defined-out)) + +(define-syntax ~ (make-rename-transformer #'lazy)) +(define ! force) +(define ~? promise?) + +;; force a top-level list structure; works with improper lists (will force the +;; dotted item when it checks if its a pair); does not handle cycles +(define (!list x) + (let ([x (! x)]) + (if (list? x) ; cheap check, + x ; and big savings on this case + (let loop ([x x]) + (if (pair? x) + ;; avoid allocating when possible + (let ([r (loop (! (cdr x)))]) (if (eq? r (cdr x)) x (cons (car x) r))) + x))))) + +;; similar to !list, but also force the values in the list +(define (!!list x) + (let ([x (! x)]) + (if (list? x) ; cheap check, + (if (ormap ~? x) (map ! x) x) ; and big savings on these cases + (let loop ([x x]) + (if (pair? x) + ;; avoid allocating when possible + (if (~? (car x)) + (cons (! (car x)) (loop (! (cdr x)))) + (let ([r (loop (! (cdr x)))]) + (if (eq? r (cdr x)) x (cons (car x) r)))) + x))))) + +(define (!! x) + ;; Recursively force the input value, preserving sharing (usually indirectly + ;; specified through self-referential promises). The result is a copy of the + ;; input structure, where the scan goes down the structure that + ;; `make-reader-graph' handles. + (define t (make-weak-hasheq)) + (define placeholders? #f) + (define (loop x) (let ([x (! x)]) - (if (multiple-values? x) - (apply values (map ! (multiple-values-values x))) - x))) - - ;; Multiple values are problematic: MzScheme promises can use multiple - ;; values, but to carry that out `call-with-values' should be used in all - ;; places that deal with multiple values, which will make the whole thing - ;; much slower (about twice in tight loops) -- but multiple values are rarely - ;; used (spceifically, students never use them). So `values' is redefined to - ;; produce a first-class tuple-holding struct, and `split-values' turns that - ;; into multiple values. - (define-struct multiple-values (values)) - (define (split-values x) - (let ([x (! x)]) - (if (multiple-values? x) (apply values (multiple-values-values x)) x))) - - ;; Force a nested structure -- we don't distinguish values from promises so - ;; it's fine to destructively modify the structure. - (define (do-!! x translate-procedures?) - (define table (make-hash-table)) ; avoid loops due to sharing - (split-values ; see below - (let loop ([x x]) - (let ([x (! x)]) - (unless (hash-table-get table x (lambda () #f)) - (hash-table-put! table x #t) - (cond [(mpair? x) - (set-mcar! x (loop (car x))) - (set-mcdr! x (loop (cdr x)))] - [(vector? x) - (let vloop ([i 0]) - (when (< i (vector-length x)) - (vector-set! x i (loop (vector-ref x i))) - (vloop (add1 i))))] - [(box? x) (set-box! x (loop (unbox x)))] - [(struct? x) - (let-values ([(type skipped?) (struct-info x)]) - (if type - (let*-values ([(name initk autok ref set imms spr skp?) - (struct-type-info type)] - [(k) (+ initk autok)]) - (let sloop ([i 0]) - (unless (= i k) - (set x i (loop (ref x i))) - (sloop (add1 i))))) - x))])) - (if (and (procedure? x) translate-procedures?) - (lambda args (do-!! (apply x args) #t)) - x)))))) + ;; * Save on placeholder allocation (which will hopefully save work + ;; recopying values again when passed through `make-reader-graph') -- + ;; basic idea: scan the value recursively, marking values as visited + ;; *before* we go inside; when we get to a value that was marked, + ;; create a placeholder and use it as the mark (or use the mark value + ;; if it's already a placeholder); finally, if after we finished + ;; scanning a value -- if we see that its mark was changed to a + ;; placeholder, then put the value in it. + ;; * Looks like we could modify the structure if it's mutable instead of + ;; copying it, but that might leave the original copy with a + ;; placeholder in it. + (define-syntax-rule (do-value expr) + (let ([y (hash-ref t x #f)]) + (cond ;; first visit to this value + [(not y) (hash-set! t x #t) + (let* ([r expr] [y (hash-ref t x #f)]) + (when (placeholder? y) + (placeholder-set! y r) + (set! placeholders? #t)) + r)] + ;; already visited it twice => share the placeholder + [(placeholder? y) y] + ;; second visit => create a placeholder request + [else (let ([p (make-placeholder #f)]) (hash-set! t x p) p)]))) + ;; deal with only with values that `make-reader-graph' can handle (for + ;; example, no mpairs) -- otherwise we can get back placeholder values + ;; (TODO: hash tables) + (cond [(pair? x) + (do-value (cons (loop (car x)) (loop (cdr x))))] + [(vector? x) + (do-value (let* ([len (vector-length x)] [v (make-vector len)]) + (for ([i (in-range len)]) + (vector-set! v i (loop (vector-ref x i)))) + (if (immutable? x) (vector->immutable-vector v) v)))] + [(box? x) + (do-value ((if (immutable? x) box-immutable box) + (loop (unbox x))))] + [else + (let ([k (prefab-struct-key x)]) + (if k + (do-value (let ([v (struct->vector x)]) + (for ([i (in-range 1 (vector-length v))]) + (vector-set! v i (loop (vector-ref v i)))) + (apply make-prefab-struct k + (cdr (vector->list v))))) + x))]))) + (let ([x (loop x)]) (if placeholders? (make-reader-graph x) x))) diff --git a/collects/lazy/lazy.scrbl b/collects/lazy/lazy.scrbl index 774888dccd..350ced6bc9 100644 --- a/collects/lazy/lazy.scrbl +++ b/collects/lazy/lazy.scrbl @@ -1,20 +1,6 @@ #lang scribble/doc @(require (for-label (except-in lazy delay force promise?) - (only-in lazy/force - ! !! !!! - !list !!list - split-values !values !!values) - (only-in lazy/promise - delay force lazy promise?))) - -@(begin - (define-syntax-rule (def-scheme scheme-force scheme-delay scheme-promise?) - (begin - (require (for-label scheme/promise)) - (define scheme-force (scheme force)) - (define scheme-delay (scheme delay)) - (define scheme-promise? (scheme promise?)))) - (def-scheme scheme-force scheme-delay scheme-promise?)) + (only-in lazy/force ! !! !list !!list))) @(define-syntax-rule (deflazy mod def id) (begin @@ -158,12 +144,6 @@ Similar to @scheme[!], but recursively forces a structure (e.g: lists).} -@defproc[(!!! [expr any/c]) any/c]{ - -Similar to @scheme[!!], but also wraps procedures that if finds so -their outputs are forced (so they are useful in a strict world).} - - @defproc[(!list [expr (or/c promise? list?)]) list?]{ Forces the @scheme[expr] which is expected to be a list, and forces @@ -176,13 +156,14 @@ Similar to @scheme[!list] but also forces (using @scheme[!]) the elements of the list.} +@;{ This moved into lazy.ss, and all the other forces will move there too. + @subsection{Multiple values} To avoid dealing with multiple values, they are treated as a single tuple in the lazy language. This is implemented as a @scheme[multiple-values] struct, with a @scheme[values] slot. - @defproc[(split-values [x multiple-values?]) any]{ Used to split such a tuple to actual multiple values. (This may change @@ -199,102 +180,4 @@ Forces @scheme[expr] and uses @scheme[split-values] on the result.} Similar to @scheme[!values], but forces each of the values recursively.} -@; ---------------------------------------- - -@section{Promises} - -@defmodule[lazy/promise] - -The @schememodname[lazy/promise] module implements lazy promises as -implicitly used by the @schememodname[lazy] language. - -Note: this module implements a new kind of promises. MzScheme's -promises are therefore treated as other values---which means that they -are not forced by this module's @scheme[force]. - -Generally speaking, if you use only @scheme[delay], @scheme[force], -and @scheme[promise?], you get the same functionality as in Scheme. -See below for two (relatively minor) differences. - -@scheme[lazy] implements a new kind of promise. When used with -expressions, it behaves like @scheme[delay]. However, when -@scheme[lazy] is used with an expression that already evaluates to a -promise, it combines with it such that @scheme[force] will go through -both promises. In other words, @scheme[(lazy _expr)] is equivalent to -@scheme[(lazy (lazy _expr))]. The main feature of this implementation -of promises is that @scheme[lazy] is safe-for-space (see -@link["http://srfi.schemers.org/srfi-45/"]{SRFI-45} for -details)---this is crucial for tail-recursion in Lazy Scheme. - -To summarize, a sequence of @scheme[lazy]s is forced with a single use -of @scheme[force], and each additional @scheme[delay] requires an -additional @scheme[force]---for example, @scheme[(lazy (delay (lazy -(delay (lazy _expr)))))] requires three @scheme[force]s to evaluate -@scheme[_expr]. - -Note: @scheme[lazy] cannot be used with an expression that evaluates -to multiple values. @scheme[delay], however, is fine with multiple -values. (This is for efficiency in the lazy language, where multiple -values are avoided.) - -As mentioned above, using @scheme[delay] and @scheme[force] is as in -Scheme, except for two differences. The first is a -technicality---@scheme[force] is an identity for non-promise values. -This makes it more convenient in implementing the lazy language, where -there is no difference between a value and a promise. - -The second difference is that circular (re-entrant) promises are not -permitted (i.e., when a promise is being forced, trying to force it in -the process will raise an error). For example, the following code -(see srfi-45 for additional examples): - -@schemeblock[ -(let ([count 5]) - (define p - (delay (if (<= count 0) - count - (begin (set! count (- count 1)) - (force p))))) - (force p))] - -returns 0 with Scheme's @|scheme-delay|/@|scheme-force|, but aborts -with an error with this module's promises. This restriction leads to -faster code (see -@link["http://srfi.schemers.org/srfi-45/post-mail-archive/msg00011.html"]{a -SRFI-45 discussion post} for some additional details), while -preventing diverging code (the only reasonable way to use circular -promises is using mutation as above). - - -@defform[(delay expr)]{Similar in functionality to Scheme's @|scheme-delay|} - - -@defform[(lazy expr)]{Creates a ``lazy'' promise. See above for -details.} - - -@defproc[(force [x any/c]) any/c]{ - -Forces a promise that was generated by @scheme[delay] or -@scheme[lazy]. Similar to Scheme's @|scheme-force|, except that -non-promise values are simply returned.} - - -@defproc[(promise? [x any/c]) boolean?]{ - -A predicate for promise values.} - -@; ---------------------------------------- - -@section{MzScheme without Promises} - -@defmodule[lazy/mz-without-promises] - -The @schememodname[lazy/mz-without-promises] module simply provides -all of @schememodname[mzscheme] except for promise-related -functionality: @|scheme-delay|, @|scheme-force|, and -@|scheme-promise?|. This is because @schememodname[lazy/promise] -defines and provides the same names. It is intended as a helper, but -you can use it together with @schememodname[lazy/promise] to get a -@schememodname[mzscheme]-like language where promises are implemented -by @schememodname[lazy/promise]. +;} diff --git a/collects/lazy/lazy.ss b/collects/lazy/lazy.ss index 2d5584c5bc..4e3564a491 100644 --- a/collects/lazy/lazy.ss +++ b/collects/lazy/lazy.ss @@ -52,8 +52,8 @@ ;; the exposed `!' (and other similar !s) must be a special form in the lazy ;; language -- but this is achieved through the lazy #%app (~!%app below) ;; that treats it (and the others) specially: uses mzscheme's application - (define-for-syntax strict-forms - (syntax->list #'(! !! !!! !list !!list !values !!values))) + (define-for-syntax strict-names + (syntax->list #'(! !! !list !!list !values !!values))) ;; -------------------------------------------------------------------------- ;; Determine laziness @@ -139,6 +139,27 @@ ;; to whenever the value is actually forced (~ (parameterize ([param (! val)] ...) (~begin body ...)))) + ;; Multiple values are problematic: MzScheme promises can use multiple + ;; values, but to carry that out `call-with-values' should be used in all + ;; places that deal with multiple values, which will make the whole thing + ;; much slower (about twice in tight loops) -- but multiple values are rarely + ;; used (spceifically, students never use them). So `values' is redefined to + ;; produce a first-class tuple-holding struct, and `split-values' turns that + ;; into multiple values. + (define-struct multiple-values (values)) + (define (split-values x) + (let ([x (! x)]) + (if (multiple-values? x) (apply values (multiple-values-values x)) x))) + ;; Force and split resulting values. + (define (!values x) + (split-values (! x))) + ;; Similar, but forces the actual values too. + (define (!!values x) + (let ([x (! x)]) + (if (multiple-values? x) + (apply values (map ! (multiple-values-values x))) + x))) + (define* (~values . xs) (make-multiple-values xs)) ;; Redefine multiple-value constructs so they split the results @@ -236,7 +257,7 @@ (cond [(let ([f #'f]) (and (identifier? f) (ormap (lambda (s) (module-identifier=? f s)) - strict-forms))) + strict-names))) ;; strict function => special forms => use plain application (syntax/loc stx (f x ...))] [(toplevel?) @@ -558,7 +579,7 @@ [(pair? l) (cons (car l) (~ (loop (sub1 n) (! (cdr l)))))] [else (error 'take "not a proper list: ~e" l)]))) - ;; not like Haskell's `take' that consumes a list + ;; not like Haskell's `cycle' that consumes a list (define* (cycle . l) (letrec ([r (~ (~append (! l) r))]) r)) @@ -682,9 +703,9 @@ ;; -------------------------------------------------------------------------- ;; Provide everything except some renamed stuff - (define-syntax (provide-strict-forms stx) - #`(provide #,@strict-forms)) - (provide-strict-forms) + (define-syntax (provide-strict-names stx) + #`(provide #,@strict-names)) + (provide-strict-names) (define-syntax (renaming-provide stx) (syntax-case stx () diff --git a/collects/lazy/promise.ss b/collects/lazy/promise.ss deleted file mode 100644 index 989e6ecc0c..0000000000 --- a/collects/lazy/promise.ss +++ /dev/null @@ -1,258 +0,0 @@ -;; This module implements "lazy promises" and a `force' that is iterated -;; through them. Scheme promises are not touched: they're used as values. -;; This is similar to the *new* version of srfi-45 -- see the post-finalization -;; discussion at http://srfi.schemers.org/srfi-45/ for more details; -;; specifically, this version is the `lazy2' version from -;; http://srfi.schemers.org/srfi-45/post-mail-archive/msg00013.html and (a -;; `lazy3' variant of `force' that deals with multiple values is included and -;; commented). Note: if you use only `force'+`delay' it behaves as in Scheme -;; (except that `force' is identity for non promise values), and `force'+`lazy' -;; are sufficient for implementing the lazy language. -(module promise "mz-without-promises.ss" - - (provide lazy delay force promise?) - - ;; (define-struct promise (p)) <-- use a more sophisticated struct below - - ;; Promise records (note: print in meaningful ways like thunks) - (define-values (promise promise? p:ref p:set!) - (let*-values - ([(printer) - (lambda (promise port write?) - (let loop ([p (p:ref promise)]) - (cond - [(procedure? p) - (cond [(object-name p) - => (lambda (n) (fprintf port "#" n))] - [else (display "#" port)])] - ;; no values - [(null? p) (fprintf port "#")] - [(pair? p) - ;; single value - (fprintf port (if write? "#" port)] - [(promise? p) (loop (p:ref p))] ; hide sharing - [(not p) (display "#" port)] - [else (error 'promise-printer "bad promise value: ~e" p)])))] - [(s:promise promise promise? promise-ref promise-set!) - (make-struct-type 'promise #f 1 0 #f - (list (cons prop:custom-write printer)))]) - (values promise - promise? - (make-struct-field-accessor promise-ref 0 'contents) - (make-struct-field-mutator promise-set! 0 'contents)))) - - ;; ::= - ;; | (promise ) delayed promise - ;; | (promise (list )) forced promise (possibly multi-valued) - ;; | (promise ) shared promise - ;; | (promise #f) currently running - ;; | (promise ) exception when forced (last version) - - ;; Creates a `composable' promise - ;; X = (force (lazy X)) = (force (lazy (lazy X))) = (force (lazy^n X)) - (define-syntax (lazy stx) - (syntax-case stx () - [(lazy expr) (with-syntax ([proc (syntax-property - (syntax/loc stx (lambda () expr)) - 'inferred-name (syntax-local-name))]) - (syntax/loc stx (promise proc)))])) - - ;; Creates a promise that does not compose - ;; X = (force (delay X)) = (force (lazy (delay X))) - ;; = (force (lazy^n (delay X))) - ;; X = (force (force (delay (delay X)))) =/= (force (delay (delay X))) - ;; so each sequence of `(lazy^n o delay)^m' requires m `force's and a - ;; sequence of `(lazy^n o delay)^m o lazy^k' requires m+1 `force's (for k>0) - ;; (This is not needed with a lazy language (see the above URL for details), - ;; but provided for completeness.) - (define-syntax (delay stx) - (syntax-case stx () - [(delay expr) - ;; see below for using multiple-values: - (syntax/loc stx - (lazy (promise (call-with-values (lambda () expr) list))))])) - - ;; force iterates on lazy promises (forbid dependency cycles) - ;; * (force X) = X for non promises - ;; * does not deal with multiple values, since they're not used by the lazy - ;; language (but see below) - - #; ; this version cannot handle multiple values - (define (force promise) - (if (promise? promise) - (let loop ([p (p:ref promise)]) - (cond - [(procedure? p) - (p:set! promise #f) ; mark root for cycle detection - (let loop ([promise* (p)]) - (if (promise? promise*) - (let ([p* (p:ref promise*)]) - (p:set! promise* promise) ; share with root - (cond [(procedure? p*) (loop (p*))] - [(pair? p*) (p:set! promise p*) (car p*)] - [(promise? p*) (loop p*)] - [(not p*) (error 'force "reentrant promise")] - [else (error 'force - "invalid promise, contains ~e" p*)])) - (begin ; error here for "library approach" (see above URL) - (p:set! promise (list promise*)) - promise*)))] - [(pair? p) (car p)] - [(promise? p) (loop (p:ref p))] - [(not p) (error 'force "reentrant promise")] - [else (error 'force "invalid promise, contains ~e" p)])) - ;; different from srfi-45: identity for non-promises - promise)) - - #; ; this version works properly with multiple values - (define (force promise) - (if (promise? promise) - (let loop ([p (p:ref promise)]) - (cond - [(procedure? p) - (p:set! promise #f) ; mark root for cycle detection - (let loop1 ([vals* (call-with-values p list)]) - (if (and (pair? vals*) - (null? (cdr vals*)) - (promise? (car vals*))) - (let loop2 ([promise* (car vals*)]) - (let ([p* (p:ref promise*)]) - (p:set! promise* promise) ; share with root - (cond [(procedure? p*) (loop1 (call-with-values p* list))] - [(or (pair? p*) (null? p*)) - (p:set! promise p*) - (apply values p*)] - [(promise? p*) (loop2 p*)] - [(not p*) (error 'force "reentrant promise")] - [else (error 'force - "invalid promise, contains ~e" p*)]))) - (begin ; error here for "library approach" (see above URL) - (p:set! promise vals*) - (apply values vals*))))] - [(or (pair? p) (null? p)) (apply values p)] - [(promise? p) (loop (p:ref p))] - [(not p) (error 'force "reentrant promise")] - [else (error 'force "invalid promise, contains ~e" p)])) - ;; different from srfi-45: identity for non-promises - promise)) - - ;; this version deals with multiple values only in `delay' (technicality: - ;; actually it doesn't work with `lazy' holding `lazy' of multiple values, so - ;; `lazy' works with multiple values unless rewrapped in `lazy'.) - #; - (define (force promise) - (if (promise? promise) - (let loop ([p (p:ref promise)]) - (cond - [(procedure? p) - (p:set! promise #f) ; mark root for cycle detection - (let ([vals* (call-with-values p list)]) - (if (and (pair? vals*) (null? (cdr vals*))) - (let loop1 ([val* (car vals*)]) - (if (promise? val*) - (let loop2 ([promise* val*]) - (let ([p* (p:ref promise*)]) - (p:set! promise* promise) ; share with root - (cond [(procedure? p*) (loop1 (p*))] - [(or (pair? p*) (null? p*)) - (p:set! promise p*) - (apply values p*)] - [(promise? p*) (loop2 p*)] - [(not p*) (error 'force "reentrant promise")] - [else (error 'force - "invalid promise, contains ~e" p*)]))) - (begin ; error here for "library approach" (see above URL) - (p:set! promise (list val*)) - val*))) - (begin ; error here for "library approach" (see above URL) - (p:set! promise vals*) - (apply values vals*))))] - [(or (pair? p) (null? p)) (apply values p)] - [(promise? p) (loop (p:ref p))] - [(not p) (error 'force "reentrant promise")] - [else (error 'force "invalid promise, contains ~e" p)])) - ;; different from srfi-45: identity for non-promises - promise)) - - ;; this version is like the last one, but properly registers - ;; exceptions. - ;; #; - (define (force promise) - (if (promise? promise) - (let loop ([p (p:ref promise)]) - (cond - [(procedure? p) - (p:set! promise #f) ; mark root for cycle detection - (with-handlers* - ([void (lambda (e) - (let ([e (if (exn? e) - e - ;; make sure it's actually an exception - (make-exn (format "~s" e) - (current-continuation-marks)))]) - (p:set! promise e) - (raise e)))]) - (let ([vals* (call-with-values p list)]) - (if (and (pair? vals*) (null? (cdr vals*))) - (let loop1 ([val* (car vals*)]) - (if (promise? val*) - (let loop2 ([promise* val*]) - (let ([p* (p:ref promise*)]) - (p:set! promise* promise) ; share with root - (cond [(procedure? p*) (loop1 (p*))] - [(or (pair? p*) (null? p*)) - (p:set! promise p*) - (apply values p*)] - [(promise? p*) (loop2 p*)] - [(not p*) (error 'force "reentrant promise")] - [else (error 'force - "invalid promise, contains ~e" - p*)]))) - (begin ; error here for "library approach" (see above URL) - (p:set! promise (list val*)) - val*))) - (begin ; error here for "library approach" (see above URL) - (p:set! promise vals*) - (apply values vals*)))))] - [(or (pair? p) (null? p)) (apply values p)] - [(promise? p) (loop (p:ref p))] - [(exn? p) (raise p)] - [(not p) (error 'force "reentrant promise")] - [else (error 'force "invalid promise, contains ~e" p)])) - ;; different from srfi-45: identity for non-promises - promise)) - - #| - - Timing results (#1, #2, #3, #4 are the above versions), in Lazy Scheme: - - loop: (define (foo n) (if (zero? n) n (foo (sub1 n)))) - (time (! (foo 2000000))) - #1 cpu time: 2067 real time: 2069 gc time: 194 - #2 cpu time: 3057 real time: 3058 gc time: 231 - #3 cpu time: 2566 real time: 2567 gc time: 235 - #4 cpu time: 4744 real time: 4746 gc time: 539 - cpu time: 4331 real time: 4334 gc time: 237 ; now with 4.0.1.1 - cpu time: 2362 real time: 2361 gc time: 148 ; using scheme/promise - ;; what-if call-with-exception-handler was tail-recursive - cpu time: 2357 real time: 2357 gc time: 148 - - fib: (define (fib n) (if (<= n 1) n (+ (fib (- n 1)) (fib (- n 2))))) - (time (! (fib 29))) - #1 cpu time: 2196 real time: 2196 gc time: 200 - #2 cpu time: 3194 real time: 3195 gc time: 227 - #3 cpu time: 2833 real time: 2833 gc time: 231 - #4 cpu time: 5837 real time: 5837 gc time: 712 - cpu time: 5328 real time: 5329 gc time: 297 ; now with 4.0.1.1 - cpu time: 2685 real time: 2688 gc time: 154 ; using scheme/promise - ;; what-if call-with-exception-handler was tail-recursive - cpu time: 2579 real time: 2578 gc time: 158 - - |# - - ) diff --git a/collects/tests/lazy/main.ss b/collects/tests/lazy/main.ss new file mode 100644 index 0000000000..43277e01f4 --- /dev/null +++ b/collects/tests/lazy/main.ss @@ -0,0 +1,49 @@ +#lang scheme/base + +(require "testing.ss" lazy/force) + +;; lazy/force behavior +(test + (! 1) => 1 + (! (! 1)) => 1 + (! (~ 1)) => 1 + (! (~ (~ (~ 1)))) => 1) + +;; !list +(test + (!list (list 1 2 3)) => '(1 2 3) + (!list (~ (list 1 2 3))) => '(1 2 3) + (!list (~ (cons 1 (~ (cons 2 (~ (cons 3 (~ null)))))))) => '(1 2 3) + (!list 1) => 1 ; works on dotted lists + (!list (cons 1 2)) => '(1 . 2)) + +;; !!list +(test + (!!list (list 1 2 3)) => '(1 2 3) + (!!list (list (~ 1) (~ 2) (~ 3))) => '(1 2 3) + (!!list (list* (~ 1) (~ 2) (~ 3))) => '(1 2 . 3) + (!!list (~ (cons (~ 1) (~ (cons (~ 2) (~ (cons (~ 3) (~ null)))))))) => '(1 2 3) + (!!list (~ (cons (~ 1) (~ (list 2 3))))) => '(1 2 3) + (!!list (~ (cons (~ 1) (~ (list 2 (~ 3)))))) => '(1 2 3)) + +;; !! +(parameterize ([print-graph #t]) + (test + (!! (~ (cons (~ 1) (~ (cons (~ 2) (~ (cons (~ 3) (~ null)))))))) => '(1 2 3) + (format "~s" (!! (letrec ([ones (~ (cons 1 (~ ones)))]) ones))) + => "#0=(1 . #0#)" + (format "~s" (!! (letrec ([ones (~ (cons 1 (~ ones)))]) (list ones ones)))) + => "(#0=(1 . #0#) #0#)" + (format "~s" (!! (letrec ([x (vector 1 (~ x))]) x))) + => "#0=#(1 #0#)" + (format "~s" (!! (letrec ([x (vector-immutable 1 (~ x))]) x))) + => "#0=#(1 #0#)" + (format "~s" (!! (letrec ([x (box (~ x))]) x))) + => "#0=#�#" + (format "~s" (!! (letrec ([x (box-immutable (~ x))]) x))) + => "#0=#�#" + (format "~s" (!! (letrec ([x (make-prefab-struct 'foo 1 (~ x))]) x))) + => "#0=#s(foo 1 #0#)" + )) + +(printf "All tests passed.\n") diff --git a/collects/tests/lazy/testing.ss b/collects/tests/lazy/testing.ss new file mode 100644 index 0000000000..74667001aa --- /dev/null +++ b/collects/tests/lazy/testing.ss @@ -0,0 +1,70 @@ +#lang scheme/base + +(require (for-syntax scheme/base scheme/match)) + +(define-syntax (safe stx) + (syntax-case stx () + [(_ expr) + (with-handlers ([exn? (lambda (e) #`(list 'error #,(exn-message e)))]) + (let-values ([(_ x) (syntax-local-expand-expression + #'(with-handlers ([exn? (lambda (e) + (list 'error + (exn-message e)))]) + (cons 'value + (call-with-values (lambda () expr) + list))))]) + x))])) + +(provide test) +(define-syntax (test stx) + (define (check test blame fmt . args) + (with-syntax ([test test] [blame blame] [fmt fmt] [(arg ...) args] + [loc (string->symbol + (format "~a:~a:~a" (syntax-source blame) + (syntax-line blame) (syntax-column blame)))]) + #'(unless test + (error 'loc "test failure in ~e\n ~a" 'blame + (format fmt arg ...))))) + (define (t1 x) + #`(let ([x (safe #,x)]) + #,(check #`(and (eq? 'value (car x)) (cadr x)) x + "expected non-#f, got~a: ~e" + #'(if (eq? 'value (car x)) "" " an error") #'(cadr x)))) + (define (t2 x y) + #`(let ([x (safe #,x)] [y #,y]) + #,(check #'(and (eq? 'value (car x)) (equal? (cadr x) y)) x + "expected ~e, got~a: ~e" + #'y #'(if (eq? 'value (car x)) "" " an error") #'(cadr x)))) + (define (te x y) + #`(let ([x (safe #,x)] [y #,y]) + #,(check #'(eq? 'error (car x)) x + "expected an error, got ~e" #'(cadr x)) + #,(check #'(regexp-match? y (cadr x)) x + "bad error message expected ~e, got ~e" #'y #'(cadr x)))) + (let loop ([xs (map (lambda (x) + (if (memq (syntax-e x) '(=> <= =error> list stx)))] + [r '()]) + (let ([t (match xs + [(list* x '=> y r) (cons (t2 x y) r)] + [(list* y '<= x r) (cons (t2 x y) r)] + [(list* x '=error> y r) (cons (te x y) r)] + [(list* y ' 3 + (car '()) =error> "expects argument of type" + (if 1) =error> "if: bad syntax" + (test (/ 0)) =error> "expected non-#f" + (test 1 => 2) =error> "expected 2" + (test 1 =error> "") =error> "expected an error" + (test (/ 0) =error> "zzz") =error> "bad error message" + )