source: project/chicken/trunk/lolevel.scm @ 13148

Last change on this file since 13148 was 13148, checked in by Kon Lovett, 11 years ago

distribution/manifest : added lolevel test
tests/lolevel-tests.scm : new lolevel test (incomplete)
runtime.c : MacOS X is-a BSD
lolevel.scm : better arg checks, grouping, added record-instance procs.
chicken.h : grouped like, comments, swig-pointer is now special
manual/Unit lolevel : discussion of pointer-like & vector-like
chicken-primitive-inlines.scm : wrond identifier for unbound value predicate

File size: 22.7 KB
Line 
1;;;; lolevel.scm - Low-level routines for CHICKEN
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare
29  (unit lolevel)
30  (usual-integrations)
31  (disable-warning var redef)
32  (hide ipc-hook-0 xproc-tag
33   ##sys#check-block
34   ##sys#check-become-alist
35   ##sys#check-generic-structure
36   ##sys#check-generic-vector )
37  (foreign-declare #<<EOF
38#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__)
39# include <sys/types.h>
40#endif
41#ifndef C_NONUNIX
42# include <sys/mman.h>
43#endif
44
45#define C_w2b(x)                   C_fix(C_wordstobytes(C_unfix(x)))
46#define C_pointer_eqp(x, y)        C_mk_bool(C_c_pointer_nn(x) == C_c_pointer_nn(y))
47#define C_memmove_o(to, from, n, toff, foff) C_memmove((char *)(to) + (toff), (char *)(from) + (foff), (n))
48EOF
49) )
50
51(cond-expand
52 [paranoia]
53 [else
54  (declare
55    (no-bound-checks)
56    (no-procedure-checks-for-usual-bindings)
57    (bound-to-procedure
58     ##sys#check-pointer ##sys#check-closure ##sys#check-integer ##sys#check-special
59     ##sys#error ##sys#signal-hook 
60     ##sys#error-not-a-proper-list
61     ##sys#hash-table-ref ##sys#hash-table-set!
62     ##sys#make-pointer ##sys#make-tagged-pointer ##sys#make-locative ##sys#locative?
63     ##sys#become!
64     ##sys#make-string ##sys#make-vector ##sys#vector->closure!
65     make-property-condition make-composite-condition signal
66     ##sys#generic-structure?
67     ##sys#set-pointer-address! ##sys#address->pointer ##sys#pointer->address
68     ##sys#lambda-decoration ##sys#decorate-lambda
69     extend-procedure ) ) ] )
70
71(include "unsafe-declarations.scm")
72
73(register-feature! 'lolevel)
74
75
76;;; Helpers:
77
78(define-inline (%pointer? x)
79  (and (##core#inline "C_blockp" x) (##core#inline "C_anypointerp" x)) )
80
81(define-inline (%generic-pointer? x)
82  (or (%pointer? x)
83      (##core#inline "C_locativep" x) ) )
84
85(define-inline (%special-block? x)
86  ; generic-pointer, port, closure
87  (and (##core#inline "C_blockp" x) (##core#inline "C_specialp" x)) )
88
89(define-inline (%generic-vector? x)
90  (and (##core#inline "C_blockp" x)
91       (not (or (##core#inline "C_specialp" x)
92                (##core#inline "C_byteblockp" x)))) )
93
94(define-inline (%record-structure? x)
95  (and (##core#inline "C_blockp" x) (##core#inline "C_structurep" x)) )
96
97
98
99;;; Argument checking:
100
101(define (##sys#check-block x . loc)
102  (unless (##core#inline "C_blockp" x)
103    (##sys#error-hook
104     (foreign-value "C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR" int) (and (pair? loc) (car loc))
105     x) ) )
106
107(define (##sys#check-become-alist x loc)
108  (##sys#check-list x loc)
109  (let loop ([lst x])
110    (cond [(null? lst) ]
111          [(pair? lst)
112           (let ([a (car lst)])
113             (##sys#check-pair a loc)
114             (##sys#check-block (car a) loc)
115             (##sys#check-block (cdr a) loc)
116             (loop (cdr lst)) ) ]
117          [else
118           (##sys#signal-hook
119            #:type-error loc
120            "bad argument type - not an a-list of non-immediate objects" x) ] ) ) )
121
122(define (##sys#check-generic-structure x . loc)
123  (unless (%record-structure? x)
124    (##sys#signal-hook
125     #:type-error (and (pair? loc) (car loc))
126     "bad argument type - not a structure" x) ) )
127
128;; Vector, Structure, Pair, and Symbol
129
130(define (##sys#check-generic-vector x . loc)
131  (unless (%generic-vector? x)
132    (##sys#signal-hook
133     #:type-error (and (pair? loc) (car loc))
134     "bad argument type - not a vector-like object" x) ) )
135
136(define (##sys#check-pointer x . loc)
137  (unless (%pointer? x)
138    (##sys#error-hook
139     (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int)
140     (and (pair? loc) (car loc))
141     "bad argument type - not a pointer" x) ) )
142
143(cond-expand
144  [unsafe
145   (define-syntax ##sys#check-pointer
146     (syntax-rules ()
147       ((_ . _) (##core#undefined))))
148   (define-syntax ##sys#check-block
149     (syntax-rules ()
150       ((_ . _) (##core#undefined))))
151   (define-syntax ##sys#check-become-alist
152     (syntax-rules ()
153       ((_ . _) (##core#undefined))))
154   (define-syntax ##sys#check-generic-structure
155     (syntax-rules ()
156       ((_ . _) (##core#undefined))))
157   (define-syntax ##sys#check-generic-vector
158     (syntax-rules ()
159       ((_ . _) (##core#undefined)))) ]
160  [else] )
161
162
163;;; Move arbitrary blocks of memory around:
164
165(define move-memory!
166  (let ([memmove1 (foreign-lambda void "C_memmove_o" c-pointer c-pointer int int int)]
167        [memmove2 (foreign-lambda void "C_memmove_o" c-pointer scheme-pointer int int int)]
168        [memmove3 (foreign-lambda void "C_memmove_o" scheme-pointer c-pointer int int int)]
169        [memmove4 (foreign-lambda void "C_memmove_o" scheme-pointer scheme-pointer int int int)]
170        [typerr (lambda (x)
171                  (##sys#error-hook
172                   (foreign-value "C_BAD_ARGUMENT_TYPE_ERROR" int)
173                   'move-memory! x))]
174        [slot1structs '(mmap
175                        u8vector u16vector u32vector s8vector s16vector s32vector
176                        f32vector f64vector)] )
177    (lambda (from to #!optional n (foffset 0) (toffset 0))
178      ;
179      (define (nosizerr)
180        (##sys#error 'move-memory! "need number of bytes to move" from to))
181      ;
182      (define (sizerr . args)
183        (apply ##sys#error 'move-memory! "number of bytes to move too large" from to args)
184      ;
185      (define (checkn1 n nmax off)
186        (if (cond-expand [unsafe #t] [else (fx<= n (fx- nmax off))])
187            n
188            (sizerr n nmax) ) )
189      ;
190      (define (checkn2 n nmax nmax2 off1 off2)
191        (if (cond-expand [unsafe #t] [else (and (fx<= n (fx- nmax off1)) (fx<= n (fx- nmax2 off2)))])
192            n
193            (sizerr n nmax nmax2) ) )
194      ;
195      (##sys#check-block from 'move-memory!)
196      (##sys#check-block to 'move-memory!)
197      (let move ([from from] [to to])
198        (cond [(##sys#generic-structure? from)
199               (if (memq (##sys#slot from 0) slot1structs)
200                   (move (##sys#slot from 1) to)
201                   (typerr from) ) ]
202              [(##sys#generic-structure? to)
203               (if (memq (##sys#slot to 0) slot1structs)
204                   (move from (##sys#slot to 1))
205                   (typerr to) ) ]
206              [(%generic-pointer? from)
207               (cond [(%generic-pointer? to)
208                      (memmove1 to from (or n (nosizerr)) toffset foffset)]
209                     [(or (##sys#bytevector? to) (string? to))
210                      (memmove3 to from (checkn1 (or n (nosizerr)) (##sys#size to) toffset) toffset foffset) ]
211                     [else
212                      (typerr to)] ) ]
213              [(or (##sys#bytevector? from) (string? from))
214               (let ([nfrom (##sys#size from)])
215                 (cond [(%generic-pointer? to)
216                        (memmove2 to from (checkn1 (or n nfrom) nfrom foffset) toffset foffset)]
217                       [(or (##sys#bytevector? to) (string? to))
218                        (memmove4 to from (checkn2 (or n nfrom) nfrom (##sys#size to) foffset toffset)
219                                  toffset foffset) ]
220                       [else
221                        (typerr to)] ) ) ]
222              [else
223               (typerr from)] ) ) ) ) ) )
224
225
226;;; Copy arbitrary object:
227
228(define (object-copy x)
229  (let copy ([x x])
230    (cond [(not (##core#inline "C_blockp" x)) x]
231          [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
232          [else
233            (let* ([n (##sys#size x)]
234                   [words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n)]
235                   [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
236              (unless (or (##core#inline "C_byteblockp" x) (symbol? x))
237                (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
238                    [(fx>= i n)]
239                  (##sys#setslot y i (copy (##sys#slot y i))) ) )
240              y) ] ) ) )
241
242
243;;; Pointer operations:
244
245(define allocate (foreign-lambda c-pointer "C_malloc" int))
246(define free (foreign-lambda void "C_free" c-pointer))
247
248(define (pointer? x) (%pointer? x))
249
250(define (pointer-like? x) (%special-block? x))
251
252(define (address->pointer addr)
253  (##sys#check-integer addr 'address->pointer)
254  (##sys#address->pointer addr) )
255
256(define (pointer->address ptr)
257  (##sys#check-special ptr 'pointer->address)
258  (##sys#pointer->address ptr) )
259
260(define null-pointer ##sys#null-pointer)
261
262(define (null-pointer? ptr)
263  (##sys#check-special ptr 'null-pointer?)
264  (eq? 0 (##sys#pointer->address ptr) ) )
265
266(define (object->pointer x)
267  (and (##core#inline "C_blockp" x)
268       ((foreign-lambda* nonnull-c-pointer ((scheme-object x)) "return((void *)x);") x) ) )
269
270(define (pointer->object ptr)
271  (##sys#check-pointer ptr 'pointer->object)
272  (##core#inline "C_pointer_to_object" ptr) )
273
274(define (pointer=? p1 p2)
275  (##sys#check-special p1 'pointer=?)
276  (##sys#check-special p2 'pointer=?)
277  (##core#inline "C_pointer_eqp" p1 p2) )
278
279(define pointer-offset
280  (foreign-lambda* nonnull-c-pointer ([c-pointer ptr] [integer off])
281    "return((unsigned char *)ptr + off);") )
282
283(define align-to-word
284  (let ([align (foreign-lambda integer "C_align" integer)])
285    (lambda (x)
286      (cond [(integer? x)
287             (align x)]
288            [(%special-block? x)
289             (##sys#address->pointer (align (##sys#pointer->address x))) ]
290            [else
291             (##sys#signal-hook
292              #:type-error 'align-to-word
293              "bad argument type - not a pointer or integer" x)] ) ) ) )
294
295(define pointer-u8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned char *)p) = n;"))
296(define pointer-s8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((char *)p) = n;"))
297(define pointer-u16-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned short *)p) = n;"))
298(define pointer-s16-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((short *)p) = n;"))
299(define pointer-u32-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((C_u32 *)p) = n;"))
300(define pointer-s32-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((C_s32 *)p) = n;"))
301(define pointer-f32-set! (foreign-lambda* void ([c-pointer p] [double n]) "*((float *)p) = n;"))
302(define pointer-f64-set! (foreign-lambda* void ([c-pointer p] [float n]) "*((double *)p) = n;"))
303
304(define pointer-u8-ref
305  (getter-with-setter
306   (foreign-lambda* int ([c-pointer p]) "return(*((unsigned char *)p));")
307   pointer-u8-set!) )
308
309(define pointer-s8-ref
310  (getter-with-setter
311   (foreign-lambda* int ([c-pointer p]) "return(*((char *)p));")
312   pointer-s8-set!) )
313
314(define pointer-u16-ref
315  (getter-with-setter
316   (foreign-lambda* int ([c-pointer p]) "return(*((unsigned short *)p));")
317   pointer-u16-set!) )
318
319(define pointer-s16-ref
320  (getter-with-setter
321   (foreign-lambda* int ([c-pointer p]) "return(*((short *)p));")
322   pointer-s6-set!) )
323
324(define pointer-u32-ref
325  (getter-with-setter
326   (foreign-lambda* integer ([c-pointer p]) "return(*((C_u32 *)p));")
327   pointer-u32-set!) )
328
329(define pointer-s32-ref
330  (getter-with-setter
331   (foreign-lambda* integer ([c-pointer p]) "return(*((C_s32 *)p));")
332   pointer-s32-set!) )
333
334(define pointer-f32-ref
335  (getter-with-setter
336   (foreign-lambda* float ([c-pointer p]) "return(*((float *)p));")
337   pointer-f32-set!) )
338
339(define pointer-f64-ref
340  (getter-with-setter
341   (foreign-lambda* double ([c-pointer p]) "return(*((double *)p));")
342   pointer-f64-set!) )
343
344
345;;; Tagged-pointers:
346
347(define (tag-pointer ptr tag)
348  (let ([tp (##sys#make-tagged-pointer tag)])
349    (if (%special-block? ptr)
350        (##core#inline "C_copy_pointer" ptr tp)
351        (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'tag-pointer ptr) )
352    tp) )
353
354(define (tagged-pointer? x #!optional tag)
355  (and (##core#inline "C_blockp" x)  (##core#inline "C_taggedpointerp" x)
356       (or (not tag)
357           (equal? tag (##sys#slot x 1)) ) ) )
358
359(define (pointer-tag x)
360  (if (%special-block? x)
361      (and (##core#inline "C_taggedpointerp" x)
362           (##sys#slot x 1) )
363      (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'pointer-tag x) ) )
364
365
366;;; locatives:
367
368;; Locative layout:
369;
370; 0     Object-address + Byte-offset (address)
371; 1     Byte-offset (fixnum)
372; 2     Type (fixnum)
373;       0       vector or pair          (C_SLOT_LOCATIVE)
374;       1       string                  (C_CHAR_LOCATIVE)
375;       2       u8vector                (C_U8_LOCATIVE)
376;       3       s8vector or blob        (C_U8_LOCATIVE)
377;       4       u16vector               (C_U16_LOCATIVE)
378;       5       s16vector               (C_S16_LOCATIVE)
379;       6       u32vector               (C_U32_LOCATIVE)
380;       7       s32vector               (C_S32_LOCATIVE)
381;       8       f32vector               (C_F32_LOCATIVE)
382;       9       f64vector               (C_F64_LOCATIVE)
383; 3     Object or #f, if weak (C_word)
384
385(define (make-locative obj . index)
386  (##sys#make-locative obj (optional index 0) #f 'make-locative) )
387
388(define (make-weak-locative obj . index)
389  (##sys#make-locative obj (optional index 0) #t 'make-weak-locative) )
390
391(define (locative-set! x y) (##core#inline "C_i_locative_set" x y))
392(define locative-ref (getter-with-setter (##core#primitive "C_locative_ref") locative-set!))
393(define (locative->object x) (##core#inline "C_i_locative_to_object" x))
394(define (locative? x) (and (##core#inline "C_blockp" x) (##core#inline "C_locativep" x)))
395
396
397;;; Procedures extended with data:
398
399; Unique id for extended-procedures
400(define xproc-tag (vector 'extended))
401
402(define (extend-procedure proc data)
403  (##sys#check-closure proc 'extend-procedure)
404  (##sys#decorate-lambda
405   proc
406   (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0)))) 
407   (lambda (x i) (##sys#setslot x i (cons xproc-tag data)) x) ) )
408
409(define-inline (%procedure-data proc)
410  (##sys#lambda-decoration proc (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0))))) )
411
412(define (extended-procedure? x)
413  (and (##core#inline "C_blockp" x) (##core#inline "C_closurep" x)
414       (%procedure-data x)
415       #t) )
416
417(define (procedure-data x)
418  (and (##core#inline "C_blockp" x) (##core#inline "C_closurep" x)
419       (and-let* ([d (%procedure-data x)])
420         (##sys#slot d 1) ) ) )
421
422(define set-procedure-data!
423  (let ((extend-procedure extend-procedure))
424    (lambda (proc x)
425      (let ((p2 (extend-procedure proc x)))
426        (if (eq? p2 proc)
427            proc
428            (##sys#signal-hook
429             #:type-error 'set-procedure-data!
430             "bad argument type - not an extended procedure" proc) ) ) ) ) )
431
432
433;;; Accessors for arbitrary vector-like block objects:
434
435(define block-set! ##sys#block-set!)
436(define block-ref (getter-with-setter ##sys#block-ref ##sys#block-set!))
437
438(define (vector-like? x)
439  (%generic-vector? x) )
440
441(define (number-of-slots x)
442  (##sys#check-generic-vector x 'number-of-slots)
443  (##sys#size x) )
444
445(define (number-of-bytes x)
446  (cond [(not (##core#inline "C_blockp" x))
447         (##sys#signal-hook
448          #:type-error 'number-of-bytes
449          "cannot compute number of bytes of immediate object" x) ]
450        [(##core#inline "C_byteblockp" x)
451         (##sys#size x)]
452        [else
453         (##core#inline "C_w2b" (##sys#size x))] ) )
454
455
456;;; Record objects:
457
458;; Record layout:
459;
460; 0     Tag (symbol)
461; 1..N  Slot (object)
462
463(define (make-record-instance type . args)
464  (##sys#check-symbol type 'make-record-instance)
465  (apply ##sys#make-structure type args) )
466
467(define (record-instance? x #!optional type)
468  (and (%record-structure? x)
469       (or (not type)
470           (eq? type (##sys#slot x 0)))) )
471
472(define (record-instance-type x)
473  (##sys#check-generic-structure x 'record-instance-type)
474  (##sys#slot x 0) )
475
476(define (record-instance-length x)
477  (##sys#check-generic-structure x 'record-instance-length)
478  (fx- (##sys#size x) 1) )
479
480(define (record-instance-slot-set! x i y)
481  (##sys#check-generic-structure x 'record-instance-slot-set!)
482  (##sys#check-range i 0 (fx- (##sys#size x) 1) 'record-instance-slot-set!)
483  (##sys#setslot x (fx+ i 1) y) )
484
485(define record-instance-slot
486  (getter-with-setter
487   (lambda (x i)
488     (##sys#check-generic-structure x 'record-instance-slot)
489     (##sys#check-range i 0 (fx- (##sys#size x) 1) 'record-instance-slot)
490     (##sys#slot x (fx+ i 1)) )
491   record-instance-slot-set!))
492
493(define (record->vector x)
494  (##sys#check-generic-structure x 'record->vector)
495  (let* ([n (##sys#size x)]
496         [v (##sys#make-vector n)] )
497    (do ([i 0 (fx+ i 1)])
498         [(fx>= i n) v]
499      (##sys#setslot v i (##sys#slot x i)) ) ) )
500
501
502
503;;; Evict objects into static memory:
504
505(define-constant evict-table-size 301)
506
507(define (object-evicted? x) (##core#inline "C_permanentp" x))
508
509(define (object-evict x . allocator)
510  (let ([allocator 
511         (if (pair? allocator) (car allocator) (foreign-lambda c-pointer "C_malloc" int) ) ] 
512        [tab (##sys#make-vector evict-table-size '())] )
513    (##sys#check-closure allocator 'object-evict)
514    (let evict ([x x])
515      (cond [(not (##core#inline "C_blockp" x)) x ]
516            [(##sys#hash-table-ref tab x) ]
517            [else
518             (let* ([n (##sys#size x)]
519                    [bytes (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))]
520                    [y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))] )
521               (when (symbol? x) (##sys#setislot y 0 (void)))
522               (##sys#hash-table-set! tab x y)
523               (unless (##core#inline "C_byteblockp" x)
524                 (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
525                     [(fx>= i n)]
526                   ;; Note the use of `##sys#setislot' to avoid an entry in the mutations-table:
527                   (##sys#setislot y i (evict (##sys#slot x i))) ) )
528               y ) ] ) ) ) )
529
530(define (object-evict-to-location x ptr . limit)
531  (cond-expand [(not unsafe) (##sys#check-special ptr 'object-evict-to-location)] [else])
532  (let* ([limit (and (pair? limit)
533                     (let ([limit (car limit)])
534                       (##sys#check-exact limit 'object-evict-to-location)
535                       limit)) ]
536         [ptr2 (##sys#address->pointer (##sys#pointer->address ptr))]
537         [tab (##sys#make-vector evict-table-size '())]
538         [x2
539          (let evict ([x x])
540            (cond [(not (##core#inline "C_blockp" x)) x ]
541                  [(##sys#hash-table-ref tab x) ]
542                  [else
543                   (let* ([n (##sys#size x)]
544                          [bytes 
545                           (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
546                                (##core#inline "C_bytes" 1) ) ] )
547                     (when limit
548                       (set! limit (fx- limit bytes))
549                       (when (fx< limit 0) 
550                         (signal
551                          (make-composite-condition
552                           (make-property-condition
553                            'exn 'location 'object-evict-to-location
554                            'message "cannot evict object - limit exceeded" 
555                            'arguments (list x limit))
556                           (make-property-condition 'evict 'limit limit) ) ) ) )
557                   (let ([y (##core#inline "C_evict_block" x ptr2)])
558                     (when (symbol? x) (##sys#setislot y 0 (void)))
559                     (##sys#set-pointer-address! ptr2 (+ (##sys#pointer->address ptr2) bytes))
560                     (##sys#hash-table-set! tab x y)
561                     (unless (##core#inline "C_byteblockp" x)
562                       (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)] )
563                           [(fx>= i n)]
564                         (##sys#setislot y i (evict (##sys#slot x i))) ) ) ; see above
565                     y) ) ] ) ) ] )
566    (values x2 ptr2) ) )
567
568(define (object-release x . releaser)
569  (let ([free (if (pair? releaser) 
570                  (car releaser) 
571                  (foreign-lambda void "C_free" c-pointer) ) ]
572        [released '() ] )
573    (let release ([x x])
574      (cond [(not (##core#inline "C_blockp" x)) x ]
575            [(not (##core#inline "C_permanentp" x)) x ]
576            [(memq x released) x ]
577            [else
578             (let ([n (##sys#size x)])
579               (set! released (cons x released))
580               (unless (##core#inline "C_byteblockp" x)
581                 (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
582                     [(fx>= i n)]
583                   (release (##sys#slot x i))) )
584               (free (##sys#address->pointer (##core#inline_allocate ("C_block_address" 4) x))) ) ] ) ) ) )
585
586(define (object-size x)
587  (let ([tab (##sys#make-vector evict-table-size '())])
588    (let evict ([x x])
589      (cond [(not (##core#inline "C_blockp" x)) 0 ]
590            [(##sys#hash-table-ref tab x) 0 ]
591            [else
592             (let* ([n (##sys#size x)]
593                    [bytes
594                     (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
595                          (##core#inline "C_bytes" 1) ) ] )
596               (##sys#hash-table-set! tab x #t)
597               (unless (##core#inline "C_byteblockp" x)
598                 (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
599                     [(fx>= i n)]
600                   (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
601               bytes) ] ) ) ) )
602
603(define (object-unevict x #!optional full)
604  (let ([tab (##sys#make-vector evict-table-size '())])
605    (let copy ([x x])
606    (cond [(not (##core#inline "C_blockp" x)) x ]
607          [(not (##core#inline "C_permanentp" x)) x ]
608          [(##sys#hash-table-ref tab x) ]
609          [(##core#inline "C_byteblockp" x) 
610           (if full
611               (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
612                 (##sys#hash-table-set! tab x y)
613                 y) 
614               x) ]
615          [(symbol? x) 
616           (let ([y (##sys#intern-symbol (##sys#slot x 1))])
617             (##sys#hash-table-set! tab x y)
618             y) ]
619          [else
620           (let* ([words (##sys#size x)]
621                  [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
622             (##sys#hash-table-set! tab x y)
623             (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
624                 ((fx>= i words))
625               (##sys#setslot y i (copy (##sys#slot y i))) )
626             y) ] ) ) ) )
627
628
629;;; `become':
630
631(define (object-become! alst)
632  (cond-expand [(not unsafe) (##sys#check-become-alist alst 'object-become!)] [else])
633  (##sys#become! alst) )
634
635(define (mutate-procedure old proc)
636  (##sys#check-closure old 'mutate-procedure)
637  (##sys#check-closure proc 'mutate-procedure)
638  (let* ([n (##sys#size old)]
639         [words (##core#inline "C_words" n)]
640         [new (##core#inline "C_copy_block" old (##sys#make-vector words))] )
641    (##sys#become! (list (cons old (proc new))))
642    new ) )
643
644
645;;; Hooks:
646
647(define ipc-hook-0 #f)                  ; we need this because `##sys#invalid-procedure-call-hook' may not have free variables.
648
649(define (set-invalid-procedure-call-handler! proc)
650  (##sys#check-closure proc 'set-invalid-procedure-call-handler!)
651  (set! ipc-hook-0 proc)
652  (set! ##sys#invalid-procedure-call-hook 
653    (lambda args
654      (ipc-hook-0 ##sys#last-invalid-procedure args) ) ) )
655
656(define (unbound-variable-value . val)
657  (set! ##sys#unbound-variable-value-hook 
658    (and (pair? val)
659         (vector (car val)))) )
660
661
662;;; Access computed globals:
663
664(define (global-ref sym)
665  (##sys#check-symbol sym 'global-ref)
666  (##core#inline "C_retrieve" sym) )
667
668(define (global-set! sym x)
669  (##sys#check-symbol sym 'global-set!)
670  (##sys#setslot sym 0 x) )
671
672(define (global-bound? sym)
673  (##sys#check-symbol sym 'global-bound?)
674  (##sys#symbol-has-toplevel-binding? sym) )
675
676(define (global-make-unbound! sym)
677  (##sys#check-symbol sym 'global-make-unbound!)
678  (##sys#setslot sym 0 (##sys#slot '##sys#arbitrary-unbound-symbol 0))
679  sym )
Note: See TracBrowser for help on using the repository browser.