* 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
This commit is contained in:
Eli Barzilay
parent
545a53731a
commit
6994edd977
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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].
|
||||
;}
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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 "#<promise:~a>" n))]
|
||||
[else (display "#<promise:?>" port)])]
|
||||
;; no values
|
||||
[(null? p) (fprintf port "#<promise!>")]
|
||||
[(pair? p)
|
||||
;; single value
|
||||
(fprintf port (if write? "#<promise!~s" "#<promise!~a")
|
||||
(car p))
|
||||
(when (pair? (cdr p))
|
||||
(let ([fmt (if write? ",~s" ",~a")])
|
||||
(for-each (lambda (x) (fprintf port fmt x)) (cdr p))))
|
||||
(display ">" port)]
|
||||
[(promise? p) (loop (p:ref p))] ; hide sharing
|
||||
[(not p) (display "#<promise*active>" 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> ::=
|
||||
;; | (promise <thunk>) delayed promise
|
||||
;; | (promise (list <object>)) forced promise (possibly multi-valued)
|
||||
;; | (promise <promise>) shared promise
|
||||
;; | (promise #f) currently running
|
||||
;; | (promise <exn>) 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
|
||||
|
||||
|#
|
||||
|
||||
)
|
||||
49
collects/tests/lazy/main.ss
Normal file
49
collects/tests/lazy/main.ss
Normal file
|
|
@ -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")
|
||||
70
collects/tests/lazy/testing.ss
Normal file
70
collects/tests/lazy/testing.ss
Normal file
|
|
@ -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> <error=))
|
||||
(syntax-e x) x))
|
||||
(cdr (syntax->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 '<error= x r) (cons (te x y) r)]
|
||||
[(list* x r) (cons (t1 x) r)]
|
||||
[(list) '()])])
|
||||
(if (pair? t)
|
||||
(loop (cdr t) (cons (car t) r))
|
||||
#`(begin #,@(reverse r))))))
|
||||
|
||||
;; test the `test' macro
|
||||
|
||||
(test (< 1 2)
|
||||
(+ 1 2) => 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"
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user