1;; Sometimes helpful for debugging: flip #t to #f to make
2;; some unsafe primitives safe.
3(meta-cond
4 [#t (define-syntax-rule (unsafe-primitive id) #3%id)]
5 [else (define-syntax-rule (unsafe-primitive id) id)])
6
7(define unsafe-car (unsafe-primitive car))
8(define unsafe-cdr (unsafe-primitive cdr))
9(define unsafe-list-tail (unsafe-primitive list-tail))
10(define unsafe-list-ref (unsafe-primitive list-ref))
11(define (unsafe-set-immutable-car! p a) ((unsafe-primitive set-car!) p a))
12(define (unsafe-set-immutable-cdr! p d) ((unsafe-primitive set-cdr!) p d))
13
14(define unsafe-char=? (unsafe-primitive char=?))
15(define unsafe-char<? (unsafe-primitive char<?))
16(define unsafe-char>? (unsafe-primitive char>?))
17(define unsafe-char>=? (unsafe-primitive char>=?))
18(define unsafe-char<=? (unsafe-primitive char<=?))
19(define unsafe-char->integer (unsafe-primitive char->integer))
20
21(define unsafe-fx+ (unsafe-primitive fx+))
22(define unsafe-fx+/wraparound (unsafe-primitive fx+/wraparound))
23(define unsafe-fx- (unsafe-primitive fx-))
24(define unsafe-fx-/wraparound (unsafe-primitive fx-/wraparound))
25(define unsafe-fx* (unsafe-primitive fx*))
26(define unsafe-fx*/wraparound (unsafe-primitive fx*/wraparound))
27(define (unsafe-fxquotient n d) (#3%fxquotient n d))
28(define unsafe-fxremainder (unsafe-primitive fxremainder))
29(define unsafe-fxmodulo (unsafe-primitive fxmodulo))
30(define unsafe-fxabs (unsafe-primitive fxabs))
31(define unsafe-fxand (unsafe-primitive fxand))
32(define unsafe-fxior (unsafe-primitive fxior))
33(define unsafe-fxxor (unsafe-primitive fxxor))
34(define unsafe-fxnot (unsafe-primitive fxnot))
35(define unsafe-fxrshift (unsafe-primitive fxarithmetic-shift-right))
36(define unsafe-fxlshift (unsafe-primitive fxarithmetic-shift-left))
37(define unsafe-fxlshift/wraparound (unsafe-primitive fxsll/wraparound))
38
39(define unsafe-fx= (unsafe-primitive fx=))
40(define unsafe-fx< (unsafe-primitive fx<))
41(define unsafe-fx> (unsafe-primitive fx>))
42(define unsafe-fx>= (unsafe-primitive fx>=))
43(define unsafe-fx<= (unsafe-primitive fx<=))
44(define unsafe-fxmin (unsafe-primitive fxmin))
45(define unsafe-fxmax (unsafe-primitive fxmax))
46
47(define unsafe-fl+ (unsafe-primitive fl+))
48(define unsafe-fl- (unsafe-primitive fl-))
49(define unsafe-fl* (unsafe-primitive fl*))
50(define unsafe-fl/ (unsafe-primitive fl/))
51(define unsafe-flabs (unsafe-primitive flabs))
52
53(define unsafe-fl= (unsafe-primitive fl=))
54(define unsafe-fl< (unsafe-primitive fl<))
55(define unsafe-fl> (unsafe-primitive fl>))
56(define unsafe-fl>= (unsafe-primitive fl>=))
57(define unsafe-fl<= (unsafe-primitive fl<=))
58(define unsafe-flmin (unsafe-primitive flmin))
59(define unsafe-flmax (unsafe-primitive flmax))
60
61(define unsafe-fx->fl (unsafe-primitive fixnum->flonum))
62(define unsafe-fl->fx (unsafe-primitive flonum->fixnum))
63
64(define unsafe-flround (unsafe-primitive flround))
65(define unsafe-flfloor (unsafe-primitive flfloor))
66(define unsafe-flceiling (unsafe-primitive flceiling))
67(define unsafe-fltruncate (unsafe-primitive fltruncate))
68(define unsafe-flsingle (unsafe-primitive flsingle))
69
70(define unsafe-flsin (unsafe-primitive flsin))
71(define unsafe-flcos (unsafe-primitive flcos))
72(define unsafe-fltan (unsafe-primitive fltan))
73(define unsafe-flasin (unsafe-primitive flasin))
74(define unsafe-flacos (unsafe-primitive flacos))
75(define unsafe-flatan (unsafe-primitive flatan))
76(define unsafe-fllog (unsafe-primitive fllog))
77(define unsafe-flexp (unsafe-primitive flexp))
78(define unsafe-flsqrt (unsafe-primitive flsqrt))
79(define unsafe-flexpt (unsafe-primitive flexpt))
80
81(define (unsafe-flrandom gen) (pseudo-random-generator-next! gen))
82
83(define unsafe-vector*-length (unsafe-primitive vector-length))
84(define unsafe-vector*-ref (unsafe-primitive vector-ref))
85(define unsafe-vector*-set! (unsafe-primitive vector-set!))
86(define unsafe-vector*-cas! (unsafe-primitive vector-cas!))
87
88(define (unsafe-struct*-cas! s k old new)
89  (#3%$record-cas! s k old new))
90
91(define unsafe-unbox* (unsafe-primitive unbox))
92(define unsafe-set-box*! (unsafe-primitive set-box!))
93(define unsafe-box*-cas! (unsafe-primitive box-cas!))
94
95(define unsafe-bytes-length (unsafe-primitive bytevector-length))
96(define unsafe-bytes-ref (unsafe-primitive bytevector-u8-ref))
97(define unsafe-bytes-set! (unsafe-primitive bytevector-u8-set!))
98
99(define unsafe-bytes-copy!
100  (case-lambda
101    [(dest d-start src)
102     (unsafe-bytes-copy! dest d-start src 0 (bytevector-length src))]
103    [(dest d-start src s-start)
104     (unsafe-bytes-copy! dest d-start src s-start (bytevector-length src))]
105    [(dest d-start src s-start s-end)
106     (bytevector-copy! src s-start dest d-start (fx- s-end s-start))]))
107
108(define unsafe-string-length (unsafe-primitive string-length))
109(define unsafe-string-ref (unsafe-primitive string-ref))
110(define unsafe-string-set! (unsafe-primitive string-set!))
111
112(define unsafe-fxvector-length (unsafe-primitive fxvector-length))
113(define unsafe-fxvector-ref (unsafe-primitive fxvector-ref))
114(define unsafe-fxvector-set! (unsafe-primitive fxvector-set!))
115
116(define unsafe-flvector-length (unsafe-primitive flvector-length))
117(define unsafe-flvector-ref (unsafe-primitive flvector-ref))
118(define unsafe-flvector-set! (unsafe-primitive flvector-set!))
119
120(define (unsafe-s16vector-ref s16 k)
121  (let* ([cptr (unsafe-struct*-ref s16 0)]
122         [mem (cpointer-memory cptr)]
123         [k (fx* k 2)])
124    (if (bytes? mem)
125        (bytevector-s16-native-ref mem k)
126        (foreign-ref 'integer-16 mem k))))
127(define (unsafe-s16vector-set! s16 k v)
128  (let* ([cptr (unsafe-struct*-ref s16 0)]
129         [mem (cpointer-memory cptr)]
130         [k (fx* k 2)])
131    (if (bytes? mem)
132        (bytevector-s16-native-set! mem k v)
133        (foreign-set! 'integer-16 mem k v))))
134
135(define (unsafe-u16vector-ref u16 k)
136  (let* ([cptr (unsafe-struct*-ref u16 0)]
137         [mem (cpointer-memory cptr)]
138         [k (fx* k 2)])
139    (if (bytes? mem)
140        (bytevector-u16-native-ref mem k)
141        (foreign-ref 'unsigned-16 mem k))))
142(define (unsafe-u16vector-set! u16 k v)
143  (let* ([cptr (unsafe-struct*-ref u16 0)]
144         [mem (cpointer-memory cptr)]
145         [k (fx* k 2)])
146    (if (bytes? mem)
147        (bytevector-u16-native-set! mem k v)
148        (foreign-set! 'unsigned-16 mem k v))))
149
150(define (unsafe-f64vector-ref f64 k)
151  (let* ([cptr (unsafe-struct*-ref f64 0)]
152         [mem (cpointer-memory cptr)]
153         [k (fx* k 8)])
154    (if (bytes? mem)
155        (bytevector-ieee-double-native-ref mem k)
156        (foreign-ref 'double mem k))))
157(define (unsafe-f64vector-set! f64 k v)
158  (let* ([cptr (unsafe-struct*-ref f64 0)]
159         [mem (cpointer-memory cptr)]
160         [k (fx* k 8)])
161    (if (bytes? mem)
162        (bytevector-ieee-double-native-set! mem k v)
163        (foreign-set! 'double mem k v))))
164
165;; FIXME
166(define (unsafe-f80vector-ref f80 k)
167  (let* ([cptr (unsafe-struct*-ref f80 0)]
168         [mem (cpointer-memory cptr)])
169    (if (bytes? mem)
170        (bytevector-ieee-double-native-ref mem k)
171        (foreign-ref 'double mem k))))
172(define (unsafe-f80vector-set! f80 k v)
173  (let* ([cptr (unsafe-struct*-ref f80 0)]
174         [mem (cpointer-memory cptr)])
175    (if (bytes? mem)
176        (bytevector-ieee-double-native-set! mem k v)
177        (foreign-set! 'double mem k v))))
178
179(define (unsafe-make-flrectangular r i)
180  (#3%make-rectangular r i))
181(define (unsafe-flreal-part c)
182  (#3%real-part c))
183(define (unsafe-flimag-part c)
184  (#3%imag-part c))
185
186(define-syntax (immutable-constant stx)
187  (syntax-case stx ()
188    [(i-c v)
189     (datum->syntax
190      #'i-c
191      (list 'quote
192            (let ([v (#%syntax->datum #'v)])
193              (cond
194                [(bytevector? v) (bytevector->immutable-bytevector v)]
195                [(string? v) (string->immutable-string v)]
196                [(#%vector? v) (#%vector->immutable-vector v)]))))]))
197
198(define (unsafe-bytes->immutable-bytes! s)
199  (cond
200    [(= (bytes-length s) 0) (immutable-constant #vu8())]
201    [else
202     (#%$bytevector-set-immutable! s)
203     s]))
204(define (unsafe-string->immutable-string! s)
205  (cond
206    [(= (string-length s) 0) (immutable-constant "")]
207    [else
208     (#%$string-set-immutable! s)
209     s]))
210(define (unsafe-vector*->immutable-vector! v)
211  (vector->immutable-vector v)
212  ;; The implementation below is not right, because the vector
213  ;; may contain elements allocated after the vector itself, and
214  ;; wrong-way pointers are not supposed to show up in mutable
215  ;; vectors. Maybe the GC should treat immutable vectors like
216  ;; mutable ones, and then morphing to immutable would be ok.
217  #;
218  (cond
219    [(= (vector-length v) 0)  (immutable-constant #())]
220    [else
221     (#%$vector-set-immutable! v)
222     v]))
223
224;; The black hole object is an immediate in Chez Scheme,
225;; so a use is compact and the optimize can recognize
226;; comparsions to itself:
227(define unsafe-undefined '#0=#0#)
228
229(define (check-not-unsafe-undefined v sym)
230  (when (eq? v unsafe-undefined)
231    (raise (|#%app|
232            exn:fail:contract:variable
233            (string-append (symbol->string sym)
234                           ": undefined;\n cannot use before initialization")
235            (current-continuation-marks)
236            sym)))
237  v)
238
239(define (check-not-unsafe-undefined/assign v sym)
240  (when (eq? v unsafe-undefined)
241    (raise (|#%app|
242            exn:fail:contract:variable
243            (string-append (symbol->string sym)
244                           ": assignment disallowed;\n cannot assign before initialization")
245            (current-continuation-marks)
246            sym)))
247  v)
248
249(define unsafe-assert-unreachable (unsafe-primitive assert-unreachable))
250