source: project/release/4/object-evict/object-evict.scm @ 31138

Last change on this file since 31138 was 31138, checked in by felix winkelmann, 6 years ago

added preliminary eggs for extraction from core libraries

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