Changeset 13837 in project


Ignore:
Timestamp:
03/19/09 05:47:48 (11 years ago)
Author:
Kon Lovett
Message:

Added bounded space wrapper. Since replacement of core routines use of primitives.

Location:
release/4/srfi-45/trunk
Files:
1 added
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/srfi-45/trunk/srfi-45.meta

    r13828 r13837  
    99 (needs setup-helper)
    1010 (files
     11  "chicken-primitive-object-inlines.scm"
    1112  "tests"
    1213  "srfi-45.scm"
  • release/4/srfi-45/trunk/srfi-45.scm

    r13809 r13837  
    33
    44;; Issues
     5;;
     6;; - All operations inlined & primitive due to high-performance nature.
    57;;
    68;; - This has been heavily modified from the original in order to extend
    79;; rather than supplant the R5RS 'delay'.
    810
     11;;; Prelude
     12
    913(declare
    1014  (usual-integrations)
     15  (disable-interrupts)
    1116  (fixnum)
    1217  (local)
    1318  (inline)
    14   (no-procedure-checks) )
     19  (no-procedure-checks)
     20  (bound-to-procedure
     21    ##sys#signal-hook))
     22
     23(include "chicken-primitive-object-inlines")
     24
     25;; Recursive promise
     26
     27(define-inline (%make-promise-box tag val) (%cons tag val))
     28(define-inline (%promise-box? obj) (%pair? obj))
     29(define-inline (%promise-box-tag prm) (%car prm))
     30(define-inline (%promise-box-value prm) (%cdr prm))
     31(define-inline (%promise-box-tag-set! prm tag) (%set-car!/mutate prm tag))
     32(define-inline (%promise-box-value-set! prm val) (%set-cdr! prm val))
     33
     34(define-inline (%make-promise tag val) (make-box (%make-promise-box tag val)))
     35(define-inline (%promise-box-ref prmbox) (*box-structure-ref prmbox))
     36(define-inline (%promise-box-set! box prmbox) (*box-structure-set! box prmbox))
     37
     38(define-inline (%promise-box?->promise-box obj)
     39  (and (*box-structure? obj)
     40       (let ((boxed (%promise-box-ref obj)))
     41         (and (%promise-box? boxed)
     42              boxed ) ) ) )
     43
     44(define-inline (%lazy-promise? obj)
     45  (and-let* ((boxed (%promise-box?->promise-box obj)))
     46    (%eq? lazy-tag (%promise-box-tag boxed))) )
     47
     48(define-inline (%eager-promise? obj)
     49  (and-let* ((boxed (%promise-box?->promise-box obj)))
     50    (%eq? eager-tag (%promise-box-tag boxed) ) ) )
     51
     52(define-inline (%promise? obj)
     53  (and-let* ((boxed (%promise-box?->promise-box obj)))
     54    (let ((tag (%promise-box-tag boxed)))
     55      (or (%eq? lazy-tag tag)
     56          (%eq? eager-tag tag) ) ) ) )
     57
     58(define-inline (%lazy-thunk? obj)
     59  (and-let* ((dat (procedure-data obj)))
     60    (%eq? thunk-tag dat) ) )
     61
     62;;; Module srfi-45
    1563
    1664(require-library box)
     
    2775  recursive-promise?
    2876  ; Macro support
    29   $eager-tag $lazy-tag)
    30 
    31 (import (rename scheme (promise? r5rs:promise?) (force r5rs:force)) chicken box)
     77  $finlzy)
     78
     79(import (rename scheme (force r5rs:force))
     80        (rename chicken (promise? r5rs:promise?))
     81        (only lolevel procedure-data extend-procedure)
     82        (only box make-box *box-structure? *box-structure-ref *box-structure-set!))
     83
     84;; Errors
     85
     86(define (error-promise-type loc obj)
     87  (##sys#signal-hook #:type-error loc "bad argument type - not a promise" obj) )
     88
     89(define (error-promise-corrupt loc prm)
     90  (##sys#signal-hook #:type-error loc "promise is corrupt" prm) )
     91
     92;; Unique Ids
     93
     94(define lazy-tag (%make-unique-object 'lazy))
     95(define eager-tag (%make-unique-object 'eager))
     96(define thunk-tag (%make-unique-object 'thunk))
    3297
    3398;; Helpers
    3499
    35 (define (make-unique-object #!optional id) (if id (vector id) '#()))
    36 
    37 (define *lazy-tag* (make-unique-object 'lazy))
    38 (define $eager-tag (make-unique-object 'eager))
    39 
    40 ;; Macros
     100(define ($finlzy thunk)
     101  (%make-promise lazy-tag (extend-procedure thunk thunk-tag)) )
     102
     103;; Constructors
    41104
    42105(define-syntax lazy
    43106  (syntax-rules ()
    44107    ((_ ?expr)
    45      (make-box (cons $lazy-tag (lambda () ?expr))) ) ) )
    46 
    47 (define-syntax eager
    48   (syntax-rules ()
    49     ((_ ?expr)
    50      (make-box (cons $eager-tag ?expr)) ) ) )
     108     ($finlzy (lambda () ?expr)) ) ) )
     109
     110(define (eager value) (%make-promise eager-tag value))
    51111
    52112;; Predicates
    53113
    54 (define (lazy-promise? obj)
    55   (and (box? obj)
    56        (let ((boxed (box-ref obj)))
    57          (and (pair? boxed) (eq? $lazy-tag (car boxed))))) )
    58 
    59 (define (eager-promise? obj)
    60   (and (box? obj)
    61        (let ((boxed (box-ref obj)))
    62          (and (pair? boxed) (eq? $eager-tag (car boxed))))) )
    63 
    64 (define (recursive-promise? obj) (or (lazy-promise? obj) (eager-promise? obj)))
    65 
    66 (define (promise? obj) (or (r5rs:promise? obj) (recursive-promise? obj)))
     114(define (lazy-promise? obj) (%lazy-promise? obj))
     115(define (eager-promise? obj) (%eager-promise? obj))
     116(define (recursive-promise? obj) (%promise? obj))
     117(define (promise? obj) (or (r5rs:promise? obj) (%promise? obj)))
    67118
    68119;; Force
    69120
    70 (define (force obj)
    71       ; a r5rs:promise?
    72   (if (not (box? obj)) (r5rs:force obj)
    73       ; then must be a recursive-promise
    74       (let ((force-content (box-ref obj)))
    75         (if (not (pair? force-content)) (error 'force "unknown promise" obj)
    76             (let ((value (cdr force-content)))
    77               (case (car force-content)
    78                 ((eager)
    79                  value )
    80                 ((lazy)
    81                   (cond ((r5rs:promise? value)      ; Wrapped r5rs promise
    82                          (r5rs:force value) )
    83                         ((procedure? value)         ; Actual lazy promise
    84                          (let ((promise (value)))
    85                            ; Re-fetch and check the original promise in case
    86                            ; the first line of the let caused it to be forced.
    87                            (let ((force-content (box-ref obj)))
    88                              ; Only propagate lazy promises
    89                              (unless (eq? $eager-tag (car force-content))
    90                                    ; A r5rs:promise?
    91                                (if (not (box? promise)) (set-cdr! force-content promise)
    92                                    ; then a recursive-promise
    93                                    (let ((promise-content (box-ref promise)))
    94                                      (set-car! force-content (car promise-content))
    95                                      (set-cdr! force-content (cdr promise-content))
    96                                      (box-set! promise force-content) ) ) ) ) )
    97                          ; Now that all the work has been done, return a result
    98                          (force obj) )
    99                        (else                       ; Already "forced"
    100                          value ) ) )
    101                 (else
    102                  (error 'force "unknown promise" obj) ) ) ) ) ) ) )
     121(define (force top)
     122
     123  ; What kind of promise?
     124  (cond
     125
     126    ; New fashion promise?
     127    ((%promise? top)
     128
     129     ; Unbox
     130     (let* ((top-box (%promise-box-ref top))
     131            (value (%promise-box-value top-box)))
     132
     133       ; Process by kind
     134       (select (%promise-box-tag top-box)
     135
     136         ; Eager has value ready
     137         ((eager-tag) (apply values value))
     138
     139         ; Force a lazy promise's value
     140         ((lazy-tag)
     141          (cond
     142
     143            ; Wrapped r5rs promise?
     144            ((r5rs:promise? value) (r5rs:force value))
     145
     146            ; Actual lazy promise?
     147            ((%lazy-thunk? value)
     148
     149             ; Force the promise by invoking the thunk
     150             (let* ((promise (call-with-values
     151                              value
     152                              (lambda xs
     153                                (cond ((%null? xs) '())
     154                                      ((%null? (%cdr xs)) (%car xs))
     155                                      (else xs))))))
     156
     157               ; Fetch and check the top promise again in case it recursed
     158               ; into `force'
     159               (let ((top-box (%promise-box-ref top)))
     160
     161                 ; Possible eager, lazy, r5rs or actual results
     162                 (cond
     163
     164                   ; Maybe eager now
     165                   ((%eq? eager-tag (%promise-box-tag top-box))
     166                    (apply values (%promise-box-value top-box)) )
     167
     168                   ; Results or a R5RS promise - force w/ updated top
     169                   ((not (%lazy-promise? promise))
     170                    (%promise-box-value-set! top-box promise)
     171                    (force top) )
     172
     173                   ; Lazy promise - force w/ updated top
     174                   (else
     175                    (let ((promise-box (%promise-box-ref promise)))
     176                      ; Copy the enclosed promise to the top
     177                      (%promise-box-tag-set! top-box (%promise-box-tag promise-box))
     178                      (%promise-box-value-set! top-box (%promise-box-value promise-box))
     179                      (%promise-box-set! promise top-box) )
     180                    (force top) ) ) ) ) )
     181
     182            ; Already "forced"
     183            (else (apply values value) ) ) )
     184
     185         ; This shouldn't happen
     186         (else
     187          (error-promise-corrupt 'force top) ) ) ) )
     188
     189    ; Old fashion promise?
     190    ((r5rs:promise? top) (r5rs:force top) )
     191
     192    ; No promise at all
     193    (else
     194     (error-promise-type 'force top) ) ) )
    103195
    104196;;;
  • release/4/srfi-45/trunk/tests/run.scm

    r13809 r13837  
    22
    33(require-extension srfi-45)
     4
     5#;
     6(define-syntax bounded-space
     7  (syntax-rules (force)
     8    ((_ (force ?expr))
     9     (force ?expr) ) ) )
     10(define-syntax bounded-space
     11  (syntax-rules (force)
     12    ((_ (force ?expr))
     13     (print "+++ Skipping Bounded Space Test: (force " '?expr ") +++") ) ) )
    414
    515;=========================================================================
     
    1626(force s)
    1727(force s)
    18                ;===> Should print 'hello once
    1928
    2029;=========================================================================
     
    2534(let ((s (delay (begin (print 'bonjour) 2))))
    2635  (+ (force s) (force s)))
    27 
    28                ;===> Should print 'bonjour once
    2936
    3037;=========================================================================
     
    3946(force t)
    4047(force r)
    41                ;===> Should print 'hi once
    4248
    4349;=========================================================================
     
    6167(car (force (stream-drop s 4)))
    6268(car (force (stream-drop s 4)))
    63 
    64                ;===> Should print 'ho five times
    6569
    6670;=========================================================================
     
    7680                    (force p)))))
    7781(define x 5)
    78 (print (force p) )                    ;===>  6
     82(print (force p))
    7983(set! x 10)
    80 (print (force p) )                    ;===>  6
     84(print (force p))
    8185
    8286
     
    9599          'second))))
    96100
    97 (print (force f) )                    ;===> 'second
     101(print (force f))
    98102
    99103;=========================================================================
    100104; Reentrancy test 3: due to John Shutt
    101105
    102 (print "+++ Should print 5, 0, then 10 +++")
     106(print "+++ Should print 5 0 10 +++")
    103107
    104108(define q
     
    115119(define p (cadr q))
    116120
    117 (print (get-count) ) ; =>   5
    118 (print (force p) )   ; =>   0
    119 (print (get-count) ) ; =>   10
     121(print (get-count))
     122(print (force p))
     123(print (get-count))
    120124
    121125;=========================================================================
     
    126130
    127131(define (loop) (lazy (loop)))
    128 ;(force (loop))                               ;==> bounded space
     132
     133(bounded-space (force (loop)))
    129134
    130135;=========================================================================
     
    133138
    134139(define s (loop))
    135 ;(force s)                                    ;==> bounded space
     140
     141(bounded-space (force s))
    136142
    137143;=========================================================================
     
    144150  (lazy (traverse (cdr (force s)))))
    145151
    146 ;(force (traverse (from 0)))                  ;==> bounded space
     152(bounded-space (force (traverse (from 0))))
    147153
    148154;=========================================================================
     
    151157
    152158(define s (traverse (from 0)))
    153 ;(force s)                                    ;==> bounded space
     159
     160(bounded-space (force s))
    154161
    155162;=========================================================================
     
    179186                       (stream-filter p? t))))))
    180187
    181 ;(force (stream-filter (lambda (n) (= n 10000000000))
    182 ;                      (from 0)))
    183                                              ;==> bounded space
     188(bounded-space (force (stream-filter (lambda (n) (= n 10000000000)) (from 0))))
    184189
    185190;========================================================================
     
    203208(print "+++ Should print 0 +++")
    204209
    205 (print
    206 (force (stream-ref (stream-filter zero? (from 0))
    207                    0))                              ;==> 0
    208  )
     210(print (force (stream-ref (stream-filter zero? (from 0)) 0))) ;==> 0
    209211
    210212(define s (stream-ref (from 0) 100000000))
    211 ;(force s)                                          ;==> bounded space
     213
     214(bounded-space (force s))
    212215
    213216;======================================================================
     
    222225(print "+++ Should print 21 +++")
    223226
    224 (print
    225 (force (times3 7))
    226  )
    227 ;(force (times3 100000000))                        ;==> bounded space
     227(print (force (times3 7)))
     228
     229(bounded-space (force (times3 100000000)))
Note: See TracChangeset for help on using the changeset viewer.