source: project/release/5/object-evict/trunk/object-evict.scm @ 35505

Last change on this file since 35505 was 35505, checked in by kooda, 7 months ago

Update CHICKEN 5's object-evict egg

File size: 5.1 KB
Line 
1;;; Evict objects into static memory
2
3
4(module object-evict (object-evicted?
5                      object-evict
6                      object-evict-to-location
7                      object-release
8                      object-size
9                      object-unevict)
10
11  (import scheme srfi-12 srfi-69 (chicken fixnum)
12          (chicken base)
13          (only (chicken memory) align-to-word allocate free))
14
15(define (object-evicted? x) (##core#inline "C_permanentp" x))
16
17(define (object-evict x . allocator)
18  (let ((allocator (if (pair? allocator) (car allocator) allocate) )
19        (tab (make-hash-table eq?)) )
20    (##sys#check-closure allocator 'object-evict)
21    (let evict ((x x))
22      (cond ((not (##core#inline "C_blockp" x)) x )
23            ((hash-table-ref/default tab x #f) )
24            (else
25             (let* ((n (##sys#size x))
26                    (bytes (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n)))
27                    (y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))) )
28               (when (symbol? x) (##sys#setislot y 0 (void)))
29               (hash-table-set! tab x y)
30               (unless (##core#inline "C_byteblockp" x)
31                 (do ((i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)))
32                     ((fx>= i n))
33                   ;; Note the use of `##sys#setislot' to avoid an entry in the mutations-table:
34                   (##sys#setislot y i (evict (##sys#slot x i))) ) )
35               y ) ) ) ) ) )
36
37(define (object-evict-to-location x ptr . limit)
38  (##sys#check-special ptr 'object-evict-to-location)
39  (let* ([limit (and (pair? limit)
40                     (let ([limit (car limit)])
41                       (##sys#check-exact limit 'object-evict-to-location)
42                       limit)) ]
43         [ptr2 (##sys#address->pointer (##sys#pointer->address ptr))]
44         [tab (make-hash-table eq?)]
45         [x2
46          (let evict ([x x])
47            (cond [(not (##core#inline "C_blockp" x)) x ]
48                  [(hash-table-ref/default tab x #f) ]
49                  [else
50                   (let* ([n (##sys#size x)]
51                          [bytes 
52                           (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
53                                (##core#inline "C_bytes" 1) ) ] )
54                     (when limit
55                       (set! limit (fx- limit bytes))
56                       (when (fx< limit 0) 
57                         (signal
58                          (make-composite-condition
59                           (make-property-condition
60                            'exn 'location 'object-evict-to-location
61                            'message "cannot evict object - limit exceeded" 
62                            'arguments (list x limit))
63                           (make-property-condition 'evict 'limit limit) ) ) ) )
64                   (let ([y (##core#inline "C_evict_block" x ptr2)])
65                     (when (symbol? x) (##sys#setislot y 0 (void)))
66                     (##sys#set-pointer-address! ptr2 (+ (##sys#pointer->address ptr2) bytes))
67                     (hash-table-set! tab x y)
68                     (unless (##core#inline "C_byteblockp" x)
69                       (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)] )
70                           [(fx>= i n)]
71                         (##sys#setislot y i (evict (##sys#slot x i))) ) ) ; see above
72                     y) ) ] ) ) ] )
73    (values x2 ptr2) ) )
74
75(define (object-release x . releaser)
76  (let ((free (if (pair? releaser) (car releaser) free ) )
77        (released '() ) )
78    (let release ((x x))
79      (cond ((not (##core#inline "C_blockp" x)) x )
80            ((not (##core#inline "C_permanentp" x)) x )
81            ((memq x released) x )
82            (else
83             (let ((n (##sys#size x)))
84               (set! released (cons x released))
85               (unless (##core#inline "C_byteblockp" x)
86                 (do ((i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)))
87                     ((fx>= i n))
88                   (release (##sys#slot x i))) )
89               (free 
90                (##sys#address->pointer
91                 (##core#inline_allocate ("C_block_address" 4) x))) ) ) ) ) ) )
92
93(define (object-size x)
94  (let ([tab (make-hash-table eq?)])
95    (let evict ([x x])
96      (cond [(not (##core#inline "C_blockp" x)) 0 ]
97            [(hash-table-ref/default tab x #f) 0 ]
98            [else
99             (let* ([n (##sys#size x)]
100                    [bytes
101                     (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
102                          (##core#inline "C_bytes" 1) ) ] )
103               (hash-table-set! tab x #t)
104               (unless (##core#inline "C_byteblockp" x)
105                 (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
106                     [(fx>= i n)]
107                   (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
108               bytes) ] ) ) ) )
109
110(define (object-unevict x #!optional full)
111  (let ([tab (make-hash-table eq?)])
112    (let copy ([x x])
113    (cond [(not (##core#inline "C_blockp" x)) x ]
114          [(not (##core#inline "C_permanentp" x)) x ]
115          [(hash-table-ref/default tab x #f) ]
116          [(##core#inline "C_byteblockp" x) 
117           (if full
118               (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
119                 (hash-table-set! tab x y)
120                 y) 
121               x) ]
122          [(symbol? x) 
123           (let ([y (##sys#intern-symbol (##sys#slot x 1))])
124             (hash-table-set! tab x y)
125             y) ]
126          [else
127           (let* ([words (##sys#size x)]
128                  [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
129             (hash-table-set! tab x y)
130             (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
131                 ((fx>= i words))
132               (##sys#setslot y i (copy (##sys#slot y i))) )
133             y) ] ) ) ) )
134
135)
Note: See TracBrowser for help on using the repository browser.