1; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
2; Part of Scheme 48 1.9.  See file COPYING for notices and license.
3
4; Authors: Richard Kelsey, Jonathan Rees, Marcus Crestani, David Frese,
5; Mike Sperber, Martin Gasbichler
6
7; This is file struct.scm.
8
9; This file defines a level of abstraction for storage somewhat higher
10; than that of d-vectors and b-vectors: pairs, symbols, and other datatypes.
11
12(define (stob-maker type maker)
13  (lambda (length key)
14    (maker type length key)))
15
16(define (stob-predicate type)
17  (lambda (obj) (stob-of-type? obj type)))
18
19; data for these comes from STOB-DATA in arch.scm
20
21(define-shared-primitive-data-type pair #t)
22(define-shared-primitive-data-type symbol #t #f
23  make-symbol                           		; hidden from RTS
24  ()
25  (symbol-next set-symbol-next!))       		; hidden from RTS
26(define-shared-primitive-data-type closure #f #f)
27(define-shared-primitive-data-type location)
28(define-shared-primitive-data-type cell)
29
30(define-shared-primitive-data-type weak-pointer)
31
32(define-shared-primitive-data-type transport-link-cell)
33
34(define-shared-primitive-data-type shared-binding #f #f
35  #f
36  ()
37  (shared-binding-next set-shared-binding-next!))	; hidden from RTS
38
39(define-shared-primitive-data-type port)
40(define-shared-primitive-data-type channel #f #f
41  make-channel                           		; hidden from RTS
42  (;; these setters are hidden from the RTS
43   (channel-status          set-channel-status!)
44   (channel-id              set-channel-id!)
45   (channel-os-index        set-channel-os-index!)
46   (channel-close-silently? set-channel-close-silently?!))
47  ;; none of these are visible to the RTS
48  (channel-next      set-channel-next!)
49  ;; this is
50  ;; false - if there's nothing going on
51  ;; true - if there's an operation pending
52  ;; the number of bytes transferred - if error? (below) is false
53  ;; the error code - if error? (below) is true
54  (channel-os-status set-channel-os-status!)
55  (channel-error?    set-channel-error?!))
56
57; Vectors and so on
58
59(define-vector-data-type vector #t)
60(define-vector-data-type record)
61(define-vector-data-type extended-number)
62
63(define make-bignum  (stob-maker (enum stob byte-vector) make-b-vector))
64(define bignum?       (stob-predicate (enum stob bignum)))
65(define bignum-length b-vector-length)
66(define bignum-ref    b-vector-ref)
67(define bignum-set!   b-vector-set!)
68(define (bignum-size len)
69  (+ stob-overhead (bytes->cells len)))
70
71
72(define-vector-data-type continuation)
73(define-vector-data-type template)
74
75(define (vm-make-vector+gc len)
76  (let ((vector (maybe-make-d-vector+gc (enum stob vector)
77					len)))
78    (if (false? vector)
79	(error "Out of space, unable to allocate"))
80    vector))
81
82(define (vm-vector-fill! v val)
83  (do ((i 0 (+ i 1)))
84      ((= i (vm-vector-length v)) v)
85    (vm-vector-set! v i val)))
86
87; We use D-VECTOR-INIT! because continuations in the heap are only initialized,
88; never modified.
89
90(define-syntax define-cont-field
91  (syntax-rules ()
92    ((define-cont-field ref set offset)
93     (begin
94       (define (ref c)     (continuation-ref c offset))
95       (define (set c val) (d-vector-init!   c offset val))))))
96
97(define-cont-field continuation-cont set-continuation-cont!
98  continuation-cont-index)
99(define-cont-field continuation-pc set-continuation-pc!
100  continuation-pc-index)
101(define-cont-field continuation-code set-continuation-code!
102  continuation-code-index)
103
104(define (template-code tem) (template-ref tem 0))
105(define (template-byte-code tem) (template-ref tem 1))
106(define (template-name tem) (template-ref tem 2))
107
108; Code vectors
109
110(define make-code-vector   (stob-maker (enum stob byte-vector) make-b-vector))
111(define code-vector?       (stob-predicate (enum stob byte-vector)))
112(define code-vector-length b-vector-length)
113(define code-vector-ref    b-vector-ref)
114(define code-vector-set!   b-vector-set!)
115
116(define (code-vector-size len)
117  (+ stob-overhead (bytes->cells len)))
118
119; for small strings only
120(define (vm-make-string length key)
121  (make-b-vector (enum stob string)
122		 (scalar-value-units->bytes length)
123		 key))
124
125(define (vm-make-string+gc length)
126  (let ((string (maybe-make-b-vector+gc (enum stob string)
127					(scalar-value-units->bytes length))))
128    (if (false? string)
129	(error "Out of space, unable to allocate"))
130    string))
131
132(define vm-string? (stob-predicate (enum stob string)))
133
134(define (vm-string-length x)
135  (bytes->scalar-value-units (b-vector-length x)))
136
137; deals in code points, not PreScheme characters
138; #### This should be rewritten as a loop the PreScheme compiler can unroll
139(define (vm-string-ref s i)
140  (let ((base (scalar-value-units->bytes i)))
141    (do ((bits 0 (+ bits bits-per-byte))
142	 (j 0 (+ 1 j))
143	 (scalar-value 0
144		     (adjoin-bits (b-vector-ref s (+ base j))
145				  scalar-value
146				  bits)))
147	((>= j bytes-per-scalar-value-unit)
148	 scalar-value))))
149
150;; #### ditto
151(define (vm-string-set! s i c)
152  (let ((base (scalar-value-units->bytes i)))
153    (do ((bits 0 (+ bits bits-per-byte))
154	 (j 0 (+ 1 j))
155	 (shifted c (unsigned-high-bits shifted bits-per-byte)))
156	((>= j bytes-per-scalar-value-unit))
157      (b-vector-set! s (+ base j)
158		     (low-bits shifted bits-per-byte)))
159    (unspecific)))			; avoid type problem
160
161(define (vm-string-size length)
162  (+ stob-overhead (bytes->cells (scalar-value-units->bytes length))))
163
164; Converting external (C, Latin-1) strings to S48 strings.
165
166; for small strings only
167(define (enter-string string key)
168  (let* ((len (string-length string))
169	 (v (vm-make-string len key)))
170    (copy-string-to-vm-string/latin-1! string len v)
171    v))
172
173(define (enter-string+gc-n string len)
174  (let ((v (vm-make-string+gc len)))
175    (copy-string-to-vm-string/latin-1! string len v)
176    v))
177
178(define (enter-string+gc string)
179  (enter-string+gc-n string (string-length string)))
180
181(define (copy-string-to-vm-string/latin-1! string len v)
182  (do ((i 0 (+ i 1)))
183      ((>= i len))
184    (vm-string-set! v i (char->ascii (string-ref string i))))
185  (unspecific))
186
187(define (copy-vm-string-to-string/latin-1! vm-string start count string)
188  (do ((i 0 (+ 1 i)))
189      ((>= i count))
190    (let ((c (vm-string-ref vm-string i)))
191      (string-set! string (+ i start)
192		   (if (<= c 255)
193		       (ascii->char c)
194		       #\?))))
195  (unspecific))
196
197(define (copy-vm-string-chars! from from-index to to-index count)
198  (copy-memory! (address+ (address-after-header from)
199			  (* from-index bytes-per-scalar-value-unit))
200		(address+ (address-after-header to)
201			  (* to-index bytes-per-scalar-value-unit))
202		(* count bytes-per-scalar-value-unit)))
203
204; This depends on our having 0 bytes at the end of strings.
205
206; We should really be doing the NUL termination here, but
207; DEFINE-CONSING-PRIMITIVE doesn't let us do it easily.
208
209(define (extract-low-string code-vector)         ; used by OPEN
210  (assert (code-vector? code-vector))
211  (fetch-nul-terminated-string (address-after-header code-vector)))
212
213(define (vm-string=? s1 s2)
214  (assert (and (vm-string? s1) (vm-string? s2)))
215  (let ((len (b-vector-length s1)))
216    (and (= len (b-vector-length s2))
217	 (memory-equal? (address-after-header s1)
218			(address-after-header s2)
219			len))))
220
221;; This is only a very crude approximation for debugging purposes.
222(define (write-vm-string vm-string out)
223  (do ((size (vm-string-length vm-string))
224       (i 0 (+ 1 i)))
225      ((>= i size) 0)			; make type checker happy
226    (write-char (ascii->char (vm-string-ref vm-string i)) out)))
227
228; Number predicates
229
230;(define bignum?       (stob-predicate (enum stob bignum)))
231(define ratnum?       (stob-predicate (enum stob ratnum)))
232(define double?       (stob-predicate (enum stob double)))
233
234; Doubles
235
236(define (extract-double double)
237  (fetch-flonum (address-after-header double)))
238
239(define double-bytes 8)
240
241(define double-size
242  (+ stob-overhead (bytes->cells double-bytes)))
243
244(define (enter-double value key)
245  (let ((double (make-b-vector (enum stob double) double-bytes key)))
246    (store-flonum! (address-after-header double) value)
247    double))
248
249; Hashing
250
251; The hash function used here is taken from srfi-13.
252
253;; biggest Unicode scalar value
254(define greatest-character-code #x10FFFF)
255
256;; BOUND has to be the biggest power of two that fulfils the following
257;; equation to make sure that the intermediate calculations of
258;; STRING-HASH are always fixnums:
259;;
260;;     (<= (+ greatest-character-code (* 37 (- BOUND 1)))
261;;         greatest-fixnum-value)
262(define bound
263  (let ((x (+ (quotient (- greatest-fixnum-value
264			   greatest-character-code) 37) 1)))
265    (let lp ((i #x10000))
266      (if (>= i x)
267	  i
268	  (lp (+ i i))))))
269
270;; bitmask to cover (- BOUND 1)
271(define mask (- bound 1))
272
273;; string hash
274(define (vm-string-hash s)
275  (let ((end (vm-string-length s)))
276    (let lp ((i 0) (ans 0))
277      (if (>= i end)
278	  (remainder ans bound)
279	  (lp (+ i 1)
280	      (bitwise-and mask (+ (* 37 ans) (vm-string-ref s i))))))))
281