source: project/chicken/tags/0.1071/lolevel.scm @ 17995

Last change on this file since 17995 was 17995, checked in by felix winkelmann, 9 years ago

imported historic version of chicken (0.1071)

File size: 28.3 KB
Line 
1;;;; lolevel.scm - Low-level routines for CHICKEN
2;
3; Copyright (c) 2000-2002, Felix L. Winkelmann
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25;
26; Send bugs, suggestions and ideas to:
27;
28; felix@call-with-current-continuation.org
29;
30; Felix L. Winkelmann
31; Steinweg 1A
32; 37130 Gleichen, OT Weissenborn
33; Germany
34
35
36(declare
37  (unit lolevel)
38  (uses srfi-4 extras)
39  (usual-integrations)
40  (foreign-declare #<<EOF
41#if defined(__FreeBSD__) || defined(__NetBSD__)
42# include <sys/types.h>
43#endif
44#ifndef C_NONUNIX
45# include <sys/mman.h>
46#endif
47#if defined(__i386__) && !defined(C_NONUNIX) && !defined(__CYGWIN__)
48# define C_valloc(n)               valloc(n)
49# define C_makeexecutable(a, n)    mprotect(a, n, PROT_READ | PROT_WRITE | PROT_EXEC)
50#elif defined(__i386__) || defined(_M_IX86)
51# define C_valloc(n)               malloc(n)
52# define C_makeexecutable(a, n)    0
53#else
54# define C_valloc(n)               NULL
55# define C_makeexecutable(a, n)    -1
56#endif
57
58#define C_pointer_to_object(ptr)   ((C_word*)C_block_item(ptr, 0))
59#define C_w2b(x)                   C_fix(C_wordstobytes(C_unfix(x)))
60EOF
61) )
62
63(cond-expand
64 [paranoia]
65 [else
66  (declare
67    (no-bound-checks)
68    (bound-to-procedure
69     ##sys#vector->closure! ##sys#error ##sys#signal-hook ##sys#address->pointer ##sys#pointer->address) ) ] )
70
71(cond-expand
72 [unsafe
73  (eval-when (compile)
74    (define-macro (##sys#check-structure x y) '(##core#undefined))
75    (define-macro (##sys#check-range x y z) '(##core#undefined))
76    (define-macro (##sys#check-pair x) '(##core#undefined))
77    (define-macro (##sys#check-list x) '(##core#undefined))
78    (define-macro (##sys#check-symbol x) '(##core#undefined))
79    (define-macro (##sys#check-string x) '(##core#undefined))
80    (define-macro (##sys#check-char x) '(##core#undefined))
81    (define-macro (##sys#check-exact x) '(##core#undefined))
82    (define-macro (##sys#check-port x) '(##core#undefined))
83    (define-macro (##sys#check-number x) '(##core#undefined))
84    (define-macro (##sys#check-byte-vector x) '(##core#undefined)) ) ]
85 [else] )
86
87
88;;; Serialization and de-serialization:
89
90(let ([fixnum-tag 0]
91      [boolean-tag 1]
92      [end-of-file-tag 2]
93      [undefined-tag 3]
94      [end-of-list-tag 4]
95      [vector-tag 5]
96      [pair-tag 6]
97      [flonum-tag 7]
98      [structure-tag 8]
99      [port-tag 9]
100      [symbol-tag 10]
101      [string-tag 11]
102      [closure-tag 12]
103      [pointer-tag 13]
104      [loop-tag 14] 
105      [character-tag 15] 
106      [bytevector-tag 16]
107      [make-string make-string]
108      [vector-ref vector-ref] )
109  (let ([tagnames (vector "fixnum" "boolean" "end-of-file" "undefined" "end-of-list" "vector" "pair" "flonum"
110                          "structure" "port" "symbol" "string" "closure" "pointer" "<loop>" "character") ] )
111
112    (define (tag->name tag) (vector-ref tagnames tag))
113
114    (set! serialize
115      (lambda (x)
116        (let ([buffer (make-u32vector 32)]
117              [index 0] 
118              [walked (make-hash-table)] )
119
120          (define (growbuffer)
121            (let ([old buffer])
122              (set! buffer (make-u32vector (fx+ (u32vector-length old) 256)))
123              (move-memory! old buffer) ) )
124
125          (define (out x)
126            (when (fx>= index (u32vector-length buffer)) (growbuffer))
127            (u32vector-set! buffer index x) 
128            (set! index (fx+ index 1)) )
129
130          (define (outn . xs)
131            (let* ([n (length xs)]
132                   [i2 (fx+ index n)] )
133              (when (fx>= i2 (u32vector-length buffer)) (growbuffer))
134              (do ([xs xs (cdr xs)]
135                   [n n (fx- n 1)] )
136                  ((zero? n))
137                (u32vector-set! buffer index (car xs))
138                (set! index (fx+ index 1)) ) ) )
139           
140          (define (walkslots x start)
141            (let ([len (##sys#size x)])
142              (do ([i start (fx+ i 1)])
143                  ((fx>= i len))
144                (walk (##sys#slot x i)) ) ) )
145
146          (define (walkbytes x)
147            (let ([len (arithmetic-shift (fx+ 3 (##sys#size x)) -2)])
148              (do ([i 0 (fx+ i 1)])
149                  ((fx>= i len))
150                (out (##sys#peek-unsigned-integer x i)) ) ) )
151
152          (define (walkspecial x tag)
153            (outn tag (##sys#size x) (##sys#peek-unsigned-integer x 0))
154            (walkslots x 1) )
155
156          (define (walk x)
157            (let ([p index]
158                  [a (hash-table-ref walked x)] )
159              (flush-output)
160              (cond [a (outn loop-tag a)]
161                    [else
162                     (when (and (##core#inline "C_blockp" x) (not (##core#inline "C_byteblockp" x)) (not (symbol? x)))
163                       (hash-table-set! walked x p) )
164                     (cond [(boolean? x) (outn boolean-tag (if x 1 0))]
165                           [(null? x) (out end-of-list-tag)]
166                           [(eof-object? x) (out end-of-file-tag)]
167                           [(eq? x (##core#undefined)) (out undefined-tag)]
168                           [(char? x) (outn character-tag (char->integer x))]
169                           [(number? x)
170                            (if (exact? x)
171                                (outn fixnum-tag x)
172                                (let* ([fv (f64vector x)]
173                                       [uv (byte-vector->u32vector (f64vector->byte-vector fv))] )
174                                  (outn flonum-tag (u32vector-ref uv 0) (u32vector-ref uv 1)) ) ) ]
175                           [(not (##core#inline "C_blockp" x)) (##sys#error "can not serialize unknown immediate object" x)]
176                           [(##sys#bytevector? x)
177                            (outn bytevector-tag (##sys#size x))
178                            (walkbytes x) ]
179                           [(vector? x)
180                            (outn vector-tag (##sys#size x))
181                            (walkslots x 0) ]
182                           [(pair? x)
183                            (outn pair-tag)
184                            (walk (car x))
185                            (walk (cdr x)) ]
186                           [(##core#inline "C_structurep" x)
187                            (outn structure-tag (##sys#size x))
188                            (walkslots x 0) ]
189                           [(string? x)
190                            (outn string-tag (##sys#size x))
191                            (walkbytes x) ]
192                           [(symbol? x)
193                            (out symbol-tag)
194                            (walk (##sys#slot x 1)) ]
195                           [(##core#inline "C_portp" x) (walkspecial x port-tag)]
196                           [(##core#inline "C_pointerp" x) (walkspecial x pointer-tag)]
197                           [(procedure? x) (walkspecial x closure-tag)]
198                           [else (##sys#error "can not serialize object" x)] ) ] ) ) )
199
200          (walk x)
201          (let ([v2 (make-u32vector index)])
202            (move-memory! buffer v2 (arithmetic-shift index 2))
203            v2) ) ) )
204
205    (set! deserialize
206      (lambda (buffer . safe)
207        (let ([safe (if (pair? safe) (car safe) #f)]
208              [index 0]
209              [gathered (make-hash-table)] )
210         
211          (define (fetch)
212            (let ([x (u32vector-ref buffer index)])
213              (set! index (fx+ index 1))
214              x) )
215
216          (define (s32ref v i)          ; needed for the cheat below.
217            (##sys#peek-signed-integer (##core#inline "C_slot" v 1) i) )
218
219          (define (fetch-signed)
220            (let ([x (s32ref buffer index)])
221              (set! index (fx+ index 1))
222              x) )
223
224          (define (inslots n x start)
225            (do ([i start (fx+ i 1)])
226                ((fx>= i n) x)
227              (##sys#setslot x i (in)) ) )
228
229          (define (inbytes len words bvec)
230            (let ([s (make-u32vector words)])
231              (do ([i 0 (fx+ i 1)])
232                  ((fx>= i words) 
233                   (let ([str 
234                          (cond [bvec
235                                 (let ([bv (##sys#allocate-vector len #t 0 #t)])
236                                   (##core#inline "C_string_to_bytevector" bv)
237                                   bv) ]
238                                [else (make-string len)] ) ] )
239                     (move-memory! s str len) 
240                     str) )
241                (u32vector-set! s i (fetch)) ) ) )
242
243          (define (inspecial x n tag)
244            (when safe 
245              (##sys#error "can not deserialize object - contains process specific data" (tag->name tag)) )
246            (##sys#poke-integer x 0 (fetch))
247            (let ([n2 (fx- n 1)])
248              (do ([i 1 (fx+ i 1)])
249                  ((fx> i n2) x)
250                (##sys#setslot x i (in)) ) ) )
251
252          (define (gather p x)
253            (when (and (##core#inline "C_blockp" x) (not (##core#inline "C_byteblockp" x)) (not (symbol? x)))
254              (hash-table-set! gathered p x) ) )
255
256          (define (in)
257            (let* ([p0 index]
258                   [tag (fetch)]
259                   [x (cond [(eq? tag boolean-tag) (eq? 1 (fetch))]
260                            [(eq? tag fixnum-tag) (fetch-signed)]
261                            [(eq? tag end-of-file-tag) (##sys#fudge 1)]
262                            [(eq? tag end-of-list-tag) '()]
263                            [(eq? tag undefined-tag) (##core#undefined)]
264                            [(eq? tag character-tag) (integer->char (fetch))]
265                            [(eq? tag bytevector-tag)
266                             (let ([len (fetch)])
267                               (inbytes len (arithmetic-shift (fx+ 3 len) -2) #t) ) ]
268                            [(eq? tag vector-tag)
269                             (let* ([len (fetch)]
270                                    [v (make-vector len)] )
271                               (gather p0 v)
272                               (inslots len v 0) ) ]
273                            [(eq? tag symbol-tag) (string->symbol (in))]
274                            [(eq? tag pair-tag)
275                             (let* ([a (in)]
276                                    [c (cons a #f)] )
277                               (gather p0 c)
278                               (set-cdr! c (in))
279                               c) ]
280                            [(eq? tag structure-tag)
281                             (let* ([len (fetch)]
282                                    [v (make-vector len)] )
283                               (gather p0 v)
284                               (##core#inline "C_vector_to_structure" v)
285                               (inslots len v 0) ) ]
286                            [(eq? tag string-tag)
287                             (let ([len (fetch)])
288                               (inbytes len (arithmetic-shift (fx+ 3 len) -2) #f) ) ]
289                            [(eq? tag flonum-tag)
290                             (let* ([f1 (fetch)]
291                                    [f2 (fetch)] )
292                               (f64vector-ref
293                                (byte-vector->f64vector
294                                 (u32vector->byte-vector (u32vector f1 f2)) ) 
295                                0) ) ]
296                            [(eq? tag port-tag)
297                             (let* ([len (fetch)]
298                                    [port (##sys#make-port #f len #f #f)] )
299                               (gather p0 port)
300                               (inspecial port len tag) ) ]
301                            [(eq? tag pointer-tag)
302                             (inspecial (##sys#make-pointer) (fetch) tag) ]
303                            [(eq? tag closure-tag)
304                             (let* ([len (fetch)]
305                                    [c (make-vector len)] )
306                               (gather p0 c)
307                               (##core#inline "C_vector_to_closure" c)
308                               (inspecial c len tag) ) ]
309                            [(eq? tag loop-tag)
310                             (let* ([p (fetch)]
311                                    [a (hash-table-ref gathered p)] )
312                               (or a (##sys#error "can not deserialize circular object - possibly corrupted" p)) ) ]
313                            [else (##sys#error "can not deserialize unknown object - possibly corrupted" tag)] ) ] )
314              (gather p0 x)
315              x) ) 
316
317          (in) ) ) ) ) )
318
319
320;;; Move arbitrary blocks of memory around:
321
322(define move-memory!
323  (let ([memmove1 (foreign-lambda void "C_memmove" c-pointer c-pointer int)]
324        [memmove2 (foreign-lambda void "C_memmove" c-pointer pointer int)]
325        [memmove3 (foreign-lambda void "C_memmove" pointer c-pointer int)]
326        [memmove4 (foreign-lambda void "C_memmove" pointer pointer int)]
327        [slot1structs '(mmap u8vector u16vector u32vector s8vector s16vector s32vector f32vector f64vector)] )
328    (lambda (from to . n)
329      (define (err) (##sys#error "need number of bytes to move" from to))
330      (define (xerr x) (##sys#signal-hook #:type-error "invalid argument type" x))
331      (define (checkn n nmax)
332        (if (cond-expand [unsafe #t] [else (fx<= n nmax)])
333            n
334            (##sys#error "number of bytes to move too large" from to n nmax) ) )
335      (define (checkn2 n nmax nmax2)
336        (if (cond-expand [unsafe #t] [else (and (fx<= n nmax) (fx<= n nmax2))])
337            n
338            (##sys#error "number of bytes to move too large" from to n nmax nmax2) ) )
339      (let move ([from from] [to to])
340        (cond [(##sys#generic-structure? from)
341               (if (memq (##sys#slot from 0) slot1structs)
342                   (move (##sys#slot from 1) to)
343                   (xerr from) ) ]
344              [(##sys#generic-structure? to)
345               (if (memq (##sys#slot to 0) slot1structs)
346                   (move from (##sys#slot to 1))
347                   (xerr to) ) ]
348              [(##sys#pointer? from)
349               (cond [(##sys#pointer? to) (memmove1 to from (:optional n (err)))]
350                     [(or (##sys#bytevector? to) (string? to))
351                      (memmove3 to from (checkn (:optional n (err)) (##sys#size to))) ]
352                     [else (xerr to)] ) ]
353              [(or (##sys#bytevector? from) (string? from))
354               (let ([nfrom (##sys#size from)])
355                 (cond [(##sys#pointer? to) (memmove2 to from (checkn (:optional n nfrom) nfrom))]
356                       [(or (##sys#bytevector? to) (string? to))
357                        (memmove4 to from (checkn2 (:optional n nfrom) nfrom (##sys#size to))) ]
358                       [else (xerr to)] ) ) ]
359              [else (xerr from)] ) ) ) ) )
360
361
362;;; Pointer operations:
363
364(define null-pointer ##sys#null-pointer)
365
366(define (pointer? x)
367  (and (##core#inline "C_blockp" x) (##core#inline "C_pointerp" x)) )
368
369(define address->pointer
370    (lambda (addr)
371      (cond-expand
372       [(not unsafe)
373        (when (not (integer? addr))
374          (##sys#signal-hook #:type-error "bad argument type - not an integer" addr) ) ]
375       [else] )
376      (##sys#address->pointer addr) ) )
377
378(define pointer->address
379    (lambda (ptr)
380      (cond-expand 
381       [(not unsafe)
382        (when (not (and (##core#inline "C_blockp" ptr) (##core#inline "C_pointerp" ptr)))
383          (##sys#signal-hook #:type-error "bad argument type - not a pointer" ptr) ) ]
384       [else] )
385      (##sys#pointer->address ptr) ) )
386
387(define null-pointer?
388    (lambda (ptr)
389      (cond-expand
390       [(not unsafe)
391        (when (not (and (##core#inline "C_blockp" ptr) (##core#inline "C_pointerp" ptr)))
392          (##sys#signal-hook #:type-error "bad argument type - not a pointer" ptr) ) ]
393       [else] )
394      (eq? 0 (##sys#pointer->address ptr) ) ) )
395
396(define (object->pointer x)
397  (and (##core#inline "C_blockp" x)
398       ((foreign-lambda* c-pointer ((scheme-object x))
399          "return((void *)x);") 
400        x) ) )
401
402(define (pointer->object ptr)
403  (cond-expand
404   [(not unsafe)
405    (when (not (and (##core#inline "C_blockp" ptr) (##core#inline "C_pointerp" ptr)))
406      (##sys#signal-hook #:type-error "bad argument type - not a pointer" ptr) ) ]
407   [else] )
408  (##core#inline "C_pointer_to_object" ptr) )
409
410(define allocate (foreign-lambda c-pointer "C_malloc" int))
411(define free (foreign-lambda void "C_free" c-pointer))
412
413(define align-to-word
414  (let ([align (foreign-lambda integer "C_align" integer)])
415    (lambda (x)
416      (cond [(number? x) (align x)]
417            [(and (##core#inline "C_blockp" x) (##core#inline "C_pointerp" x))
418             (##sys#address->pointer (align (##sys#pointer->address x))) ]
419            [else (##sys#signal-hook #:type-error "bad argument type - not a pointer or fixnum" x)] ) ) ) )
420
421
422;;; Procedures extended with data:
423
424(define extend-procedure
425  (let ([make-vector make-vector] )
426    (lambda (proc x)
427      (cond-expand 
428       [(not unsafe)
429        (unless (##core#inline "C_closurep" proc)
430          (##sys#signal-hook #:type-error "bad argument type - not a procedure" proc) ) ]
431       [else] )
432      (let ([len (##sys#size proc)])
433        (if (and (fx> len 1) (eq? ##sys#snafu (##sys#slot proc (fx- len 1)))) 
434            (begin
435              (##sys#setslot proc (fx- len 2) x)
436              proc)
437            (let* ([len2 (fx+ len 2)]
438                   [p2 (make-vector len2)] )
439              (do ([i 1 (fx+ i 1)])
440                  ((fx>= i len)
441                   (##sys#setslot p2 i x)
442                   (##sys#setslot p2 (fx+ i 1) ##sys#snafu)
443                   (##sys#vector->closure! p2 (##sys#peek-unsigned-integer proc 0))
444                   p2)
445                (##sys#setslot p2 i (##sys#slot proc i)) ) ) ) ) ) ) )
446
447(define (extended-procedure? x)
448  (and (##core#inline "C_blockp" x)
449       (##core#inline "C_closurep" x)
450       (let ([len (##sys#size x)])
451         (and (fx> len 1)
452              (eq? ##sys#snafu (##sys#slot x (fx- len 1))) ) ) ) )
453
454(define procedure-data 
455  (let ([extended-procedure? extended-procedure?] )
456    (lambda (proc)
457      (cond-expand 
458       [(not unsafe)
459        (unless (extended-procedure? proc)
460          (##sys#signal-hook #:type-error "bad argument type - not an extended procedure") ) ]
461       [else] )
462      (##sys#slot proc (fx- (##sys#size proc) 2)) ) ) )
463
464(define set-procedure-data!
465  (let ([extended-procedure? extended-procedure?] )
466    (lambda (proc x)
467      (cond-expand
468       [(not unsafe)
469        (unless (extended-procedure? proc) 
470          (##sys#signal-hook #:type-error "bad argument type - not an extended procedure") ) ]
471       [else] )
472      (##sys#setslot proc (fx- (##sys#size proc) 2) x) ) ) )
473
474
475;;; Bytevector stuff:
476
477(define (byte-vector? x)
478  (and (##core#inline "C_blockp" x)
479       (##core#inline "C_bytevectorp" x) ) )
480
481(define (byte-vector-fill! bv n)
482  (##sys#check-byte-vector bv)
483  (##sys#check-exact n)
484  (let ([len (##sys#size bv)])
485    (do ([i 0 (fx+ i 1)])
486        ((fx>= i len))
487      (##sys#setbyte bv i n) ) ) )
488
489(define make-byte-vector
490  (let ([byte-vector-fill! byte-vector-fill!])
491    (lambda (size . init)
492      (##sys#check-exact size)
493      (let ([bv (##sys#allocate-vector size #t #f #t)])
494        (##core#inline "C_string_to_bytevector" bv)
495        (when (pair? init) (byte-vector-fill! bv (car init)))
496        bv) ) ) )
497
498(define byte-vector
499  (let ([make-byte-vector make-byte-vector])
500    (lambda bytes
501      (let* ([n (length bytes)]
502             [bv (make-byte-vector n)] )
503        (do ([i 0 (fx+ i 1)]
504             [bytes bytes (##sys#slot bytes 1)] )
505            ((fx>= i n) bv)
506          (##sys#setbyte bv i (##sys#slot bytes 0)) ) ) ) ) )
507
508(define byte-vector-ref
509    (lambda (bv i)
510      (##sys#check-byte-vector bv)
511      (##sys#check-exact i)
512      (let ([n (##sys#size bv)])
513        (if (or (fx< i 0) (fx>= i n))
514            (##sys#error "out of range" bv i)
515            (##sys#byte bv i) ) ) ) )
516
517(define byte-vector-set!
518    (lambda (bv i x)
519      (##sys#check-byte-vector bv)
520      (##sys#check-exact i)
521      (##sys#check-exact x)
522      (let ([n (##sys#size bv)])
523        (if (or (fx< i 0) (fx>= i n))
524            (##sys#error "out of range" bv i)
525            (##sys#setbyte bv i x) ) ) ) )
526
527(define (byte-vector->list bv)
528  (##sys#check-byte-vector bv)
529  (let ([len (##sys#size bv)])
530    (let loop ([i 0])
531      (if (fx>= i len)
532          '()
533          (cons (##sys#byte bv i) 
534                (loop (fx+ i 1)) ) ) ) ) )
535
536(define list->byte-vector
537  (let ([make-byte-vector make-byte-vector])
538    (lambda (lst)
539      (##sys#check-list lst)
540      (let* ([n (length lst)]
541             [v (make-byte-vector n)] )
542        (do ([p lst (##sys#slot p 1)]
543             [i 0 (fx+ i 1)] )
544            ((eq? p '()) v)
545          (if (pair? p)
546              (let ([b (##sys#slot p 0)])
547                (##sys#check-exact b)
548                (##sys#setbyte v i b) )
549              (##sys#not-a-proper-list-error lst) ) ) ) ) ) )
550
551(define string->byte-vector
552  (let ([make-byte-vector make-byte-vector])
553    (lambda (s)
554      (##sys#check-string s)
555      (let* ([n (##sys#size s)]
556             [bv (make-byte-vector n)] )
557        (##core#inline "C_copy_memory" bv s n) 
558        bv) ) ) )
559
560(define byte-vector->string
561  (let ([make-string make-string])
562    (lambda (bv)
563      (##sys#check-byte-vector bv)
564      (let* ([n (##sys#size bv)]
565             [s (make-string n)] )
566        (##core#inline "C_copy_memory" s bv n) 
567        s) ) ) )
568
569(define (byte-vector-length bv)
570  (##sys#check-byte-vector bv)
571  (##sys#size bv) )
572
573(define-foreign-variable _c_header_size_mask int "C_HEADER_SIZE_MASK")
574
575(let ([byte-vector-fill! byte-vector-fill!]
576      [malloc
577       (foreign-lambda* scheme-object ((int size))
578         "char *bv;
579           if((bv = (char *)malloc(size + 3)) == NULL) return(C_SCHEME_FALSE);
580           bv = (char *)C_align((C_word)bv);
581           ((C_SCHEME_BLOCK *)bv)->header = C_BYTEVECTOR_TYPE | size;
582           return((C_word)bv);") ]
583      [xalloc
584       (foreign-lambda* scheme-object ((int size))
585         "char *bv;
586           if((bv = (char *)C_valloc(size)) == NULL) return(C_SCHEME_FALSE);
587           if(C_makeexecutable(bv, size) == -1) return(C_SCHEME_FALSE);
588           ((C_SCHEME_BLOCK *)bv)->header = C_BYTEVECTOR_TYPE | size;
589           return((C_word)bv);") ] )
590  (define (make size init alloc)
591    (##sys#check-exact size)
592    (if (fx> size _c_header_size_mask)
593        (##sys#error "out of range" size _c_header_size_mask)
594        (let ([bv (alloc size)])
595          (cond [bv
596                 (when (pair? init) (byte-vector-fill! bv (##sys#slot init 0)))
597                 bv]
598                [else (##sys#signal-hook #:runtime-error "can not allocate statically allocated bytevector" size)] ) ) ) )
599  (set! make-static-byte-vector (lambda (size . init) (make size init malloc)))
600  (set! make-executable-byte-vector (lambda (size . init) (make size init xalloc))) )
601
602(define static-byte-vector->pointer 
603  (lambda (bv)
604    (##sys#check-byte-vector bv)
605    (if (##core#inline "C_permanentp" bv)
606        (let ([p (##sys#make-pointer)])
607          (##core#inline "C_pointer_to_block" p bv)
608          p)
609        (##sys#error "can not coerce non-static bytevector" bv) ) ) )
610
611
612;;; Accessors for arbitrary block objects:
613
614(let ([check
615       (lambda (x i)
616         (when (or (not (##core#inline "C_blockp" x)) 
617                   (and (##core#inline "C_specialp" x) (fx= i 0))
618                   (##core#inline "C_byteblockp" x) ) 
619           (##sys#error "slot not accessible" x i) )
620         (when (or (fx< i 0) (fx>= i (##sys#size x)))
621           (##sys#error "slot-reference out of range" x i) ) ) ] )
622  (set! block-ref
623    (lambda (x i)
624      (##sys#check-exact i)
625      (check x i)
626      (##sys#slot x i) ) )
627  (set! block-set!
628    (lambda (x i y)
629      (##sys#check-exact i)
630      (check x i)
631      (##sys#setslot x i y) ) ) )
632
633(define number-of-slots 
634  (lambda (x)
635    (when (or (not (##core#inline "C_blockp" x)) 
636              (##core#inline "C_specialp" x)
637              (##core#inline "C_byteblockp" x) )
638      (##sys#signal-hook #:type-error "slots not accessible" x) )
639    (##sys#size x) ) )
640
641(define (number-of-bytes x)
642  (cond [(not (##core#inline "C_blockp" x))
643         (##sys#signal-hook #:type-error "can not compute number of bytes of immediate object" x) ]
644        [(##core#inline "C_byteblockp" x) (##sys#size x)]
645        [else (##core#inline "C_w2b" (##sys#size x))] ) )
646
647
648;;; Record objects:
649
650(define (make-record-instance type . args)
651  (##sys#check-symbol type)
652  (apply ##sys#make-structure type args) )
653
654(define (record-instance? x)
655  (and (##core#inline "C_blockp" x)
656       (##core#inline "C_structurep" x) ) )
657
658
659;;; Convert executable bytevector into a procedure:
660
661(define executable-byte-vector->procedure
662  (lambda (bv)
663    (##sys#check-byte-vector bv)
664    (if (##core#inline "C_permanentp" bv)
665        ((foreign-lambda* scheme-object ((scheme-object bv) (scheme-object proc))
666           "C_set_block_item(proc, 0, (C_word)(&C_block_item(bv, 0)));
667              return(proc);")
668         bv (lambda () #f) )
669        (##sys#signal-hook #:type-error "can not use non-static byte-vector for procedure code pointer" bv) ) ) )
670
671
672;;; Call code in executable bytevector:
673
674(define (invoke-executable-byte-vector bv . args)
675  (##sys#check-byte-vector bv)
676  ((foreign-lambda* scheme-object ((pointer bv) (pointer args))
677     "return(((C_word (*)(void *args))bv)(args));")
678   bv (##sys#list->vector args) ) )
679
680
681;;; Copy arbitrary object:
682
683(define copy
684  (let ([make-vector make-vector])
685    (lambda (x)
686      (let copy ([x x])
687        (if (not (##core#inline "C_blockp" x))
688            x
689            (let* ([n (##sys#size x)]
690                   [words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n)]
691                   [y (##core#inline "C_copy_block" x (make-vector words))] )
692              (unless (or (##core#inline "C_byteblockp" x) (symbol? x))
693                (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
694                    ((fx>= i n))
695                  (##sys#setslot y i (copy (##sys#slot y i))) ) )
696              y) ) ) ) ) )
697
698
699;;; Evict objects into static memory:
700
701(define (evicted? x) (##core#inline "C_permanentp" x))
702
703(define evict
704  (let ([make-hash-table make-hash-table]
705        [hash-table-ref hash-table-ref]
706        [hash-table-set! hash-table-set!] )
707    (lambda (x . allocator)
708      (let ([allocator 
709             (if (pair? allocator) 
710                 (car allocator)
711                 (foreign-lambda c-pointer "C_malloc" int) ) ] 
712            [tab (make-hash-table)] )
713        (let evict ([x x])
714          (cond [(not (##core#inline "C_blockp" x)) x]
715                [(hash-table-ref tab x)]
716                [else
717                 (let* ([n (##sys#size x)]
718                        [bytes (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))]
719                        [y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))] )
720                   (when (symbol? x) (##sys#setislot y 0 (##core#undefined)))
721                   (hash-table-set! tab x y)
722                   (unless (##core#inline "C_byteblockp" x)
723                     (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
724                         ((fx>= i n))
725                       ;; Note the use of `##sys#setislot' to avoid an entry in the mutations-table:
726                       (##sys#setislot y i (evict (##sys#slot x i))) ) )
727                   y) ] ) ) ) ) ) )
728
729(define release
730  (lambda (x . releaser)
731    (let ([free (if (pair? releaser) 
732                    (car releaser) 
733                    (foreign-lambda void "C_free" c-pointer) ) ] )
734      (let release ([x x])
735        (cond [(not (##core#inline "C_blockp" x)) x]
736              [(not (##core#inline "C_permanentp" x)) x]
737              [else
738               (let ([n (##sys#size x)])
739                 (unless (##core#inline "C_byteblockp" x)
740                   (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
741                       ((fx>= i n))
742                     (release (##sys#slot x i))) )
743                 (free (##sys#address->pointer (##core#inline "C_block_address" x))) ) ] ) ) ) ) )
744
745(define evict-to-location
746  (let ([make-hash-table make-hash-table]
747        [hash-table-ref hash-table-ref]
748        [align-to-word align-to-word]
749        [hash-table-set! hash-table-set!] )
750    (lambda (x ptr . limit)
751      (cond-expand
752       [(not unsafe)
753        (when (not (and (##core#inline "C_blockp" ptr) (##core#inline "C_pointerp" ptr)))
754          (##sys#signal-hook #:type-error "bad argument type - not a pointer" ptr) ) ]
755       [else] )
756      (let* ([limit
757              (if (pair? limit)
758                  (let ([limit (car limit)])
759                    (##sys#check-exact limit)
760                    limit)
761                  #f) ]
762             [ptr2 (##sys#address->pointer (##sys#pointer->address ptr))]
763             [tab (make-hash-table)]
764             [x2
765              (let evict ([x x])
766                (cond [(not (##core#inline "C_blockp" x)) x]
767                      [(hash-table-ref tab x)]
768                      [else
769                       (let* ([n (##sys#size x)]
770                              [bytes 
771                               (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
772                                    (##core#inline "C_bytes" 1) ) ] )
773                         (when limit
774                           (set! limit (fx- limit bytes))
775                           (when (fx< limit 0) (##sys#error "can not evict object - limit exceeded" x)) )
776                         (let ([y (##core#inline "C_evict_block" x ptr2)])
777                           (when (symbol? x) (##sys#setislot y 0 (##core#undefined)))
778                           (##sys#set-pointer-address! ptr2 (+ (##sys#pointer->address ptr2) bytes))
779                           (hash-table-set! tab x y)
780                           (unless (##core#inline "C_byteblockp" x)
781                             (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
782                                         1
783                                         0)
784                                     (fx+ i 1) ] )
785                                 ((fx>= i n))
786                               (##sys#setislot y i (evict (##sys#slot x i))) ) ) ; see above
787                           y) ) ] ) ) ] )
788        (values x2 ptr2) ) ) ) )
789
790(define object-size
791  (let ([make-hash-table make-hash-table]
792        [hash-table-ref hash-table-ref]
793        [align-to-word align-to-word]
794        [hash-table-set! hash-table-set!] )
795    (lambda (x)
796      (let ([tab (make-hash-table)])
797        (let evict ([x x])
798          (cond [(not (##core#inline "C_blockp" x)) 0]
799                [(hash-table-ref tab x) 0]
800                [else
801                 (let* ([n (##sys#size x)]
802                        [bytes
803                         (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
804                              (##core#inline "C_bytes" 1) ) ] )
805                   (hash-table-set! tab x #t)
806                   (unless (##core#inline "C_byteblockp" x)
807                     (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
808                                 1 
809                                 0)
810                             (fx+ i 1) ] )
811                         ((fx>= i n))
812                       (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
813                   bytes) ] ) ) ) ) ) )
814
815(define unevict
816  (let ([make-vector make-vector]
817        [make-hash-table make-hash-table]
818        [hash-table-set! hash-table-set!]
819        [hash-table-ref hash-table-ref] )
820    (lambda (x)
821      (define (err x)
822        (##sys#signal-hook #:type-error "can not copy object" x) )
823      (let ([tab (make-hash-table)])
824        (let copy ([x x])
825          (cond [(not (##core#inline "C_blockp" x)) x]
826                [(not (##core#inline "C_permanentp" x)) x]
827                [(##core#inline "C_byteblockp" x) x]
828                [(hash-table-ref tab x)]
829                [(symbol? x) 
830                 (let ([y (##sys#intern-symbol (##sys#slot x 1))])
831                   (hash-table-set! tab x y)
832                   y) ]
833                [else
834                 (let* ([words (##sys#size x)]
835                        [y (##core#inline "C_copy_block" x (make-vector words))] )
836                   (hash-table-set! tab x y)
837                   (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
838                       ((fx>= i words))
839                     (##sys#setslot y i (copy (##sys#slot y i))) )
840                   y) ] ) ) ) ) ) )
841
842
843;;; `become!':
844
845(define become! 
846  (cond-expand
847   [unsafe ##sys#become!]
848   [else
849    (lambda (lst)
850      (##sys#check-list lst)
851      (let loop ([lst lst])
852        (cond [(null? lst)]
853              [(pair? lst)
854               (let ([a (##sys#slot lst 0)])
855                 (##sys#check-pair a)
856                 (unless (##core#inline "C_blockp" (##sys#slot a 0))
857                   (##sys#signal-hook #:type-error "bad argument type - old item is immediate" a) )
858                 (unless (##core#inline "C_blockp" (##sys#slot a 1))
859                   (##sys#signal-hook #:type-error "bad argument type - new item is immediate" a) )
860                 (loop (##sys#slot lst 1)) ) ]
861              [else (##sys#signal-hook #:type-error "bad argument type - not an a-list")] ) )
862      (##sys#become! lst) ) ] ) )
Note: See TracBrowser for help on using the repository browser.