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