suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: performance improvements related to string encoding

Browse Source 
Streamline rktio byte-result copying (main improvement), use fixnum
arithmetic more consistently (minor improvement), and change
`in-bytes`, etc., to avoid some checks in unsafe mode (intermediate
improvement).
This commit is contained in:
Matthew Flatt 2020-11-04 11:57:52 -07:00
parent fc53f2998c
commit 18ff816358
12 changed files with 1762 additions and 2003 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
racket/collects/racket/private/for.rkt
View File

@ -942,6 +942,9 @@
(check-ranges who type-name vec start stop* step len)
(values vec start stop* step)))
(define (unsafe-normalise-inputs unsafe-vector-length vec start stop step)
(values vec start (or stop (unsafe-vector-length vec)) step))
(define-syntax define-in-vector-like
(syntax-rules ()
[(define-in-vector-like (in-vector-name check-vector-name)
@ -1034,12 +1037,15 @@
;; Outer bindings
;; start*, stop*, and step* are guaranteed to be exact integers
([(v* start* stop* step*)
(normalise-inputs (quote in-vector-name) type-name
;; reverse-eta triggers JIT inlining of
;; primitives, which is good for futures:
(lambda (x) (vector? x))
(lambda (x) (unsafe-vector-length x))
vec-expr start stop step)])
(if (variable-reference-from-unsafe? (#%variable-reference))
(unsafe-normalise-inputs unsafe-vector-length
vec-expr start stop step)
(normalise-inputs (quote in-vector-name) type-name
;; reverse-eta triggers JIT inlining of
;; primitives, which is good for futures:
(lambda (x) (vector? x))
(lambda (x) (unsafe-vector-length x))
vec-expr start stop step))])
;; Outer check is done by normalise-inputs
#t
;; Loop bindings

30
racket/src/cs/io.sls
View File

@ -219,16 +219,32 @@
(ftype-ref rktio_convert_result_t (in_consumed) p)
(ftype-ref rktio_convert_result_t (out_produced) p)
(ftype-ref rktio_convert_result_t (converted) p))))
(define (cast v from to)
(let ([p (malloc from)])
(ptr-set! p from v)
(ptr-ref p to)))
(define (copy-bytes x i)
(let ([bstr (make-bytevector i)])
(let loop ([j 0])
(unless (fx= j i)
(bytes-set! bstr j (foreign-ref 'unsigned-8 x j))
(loop (fx+ j 1))))
bstr))
(define (copy-terminated-bytes x)
(let loop ([i 0])
(if (fx= 0 (foreign-ref 'unsigned-8 x i))
(copy-bytes x i)
(loop (fx+ i 1)))))
(define (copy-terminated-shorts x)
(let loop ([i 0])
(if (fx= 0 (foreign-ref 'unsigned-16 x i))
(copy-bytes x i)
(loop (fx+ i 2)))))
(define (rktio_to_bytes fs)
(cast (ptr->address fs) _uintptr _bytes))
(copy-terminated-bytes (ptr->address fs)))
(define (rktio_to_shorts fs)
(cast (ptr->address fs) _uintptr _short_bytes))
(copy-terminated-shorts (ptr->address fs)))
;; Unlike `rktio_to_bytes`, frees the array and strings
(define rktio_to_bytes_list
@ -244,7 +260,7 @@
(let ([bs (foreign-ref 'uptr (ptr->address lls) (* i (foreign-sizeof 'uptr)))])
(if (not (eqv? NULL bs))
(cons (begin0
(cast bs _uintptr _bytes)
(copy-terminated-bytes bs)
(rktio_free (make-ptr bs)))
(loop (add1 i)))
'()))]))

486
racket/src/cs/schemified/expander.scm
View File

@ -751,27 +751,32 @@
(unsafe-bytes-length bstr_0)))
(case-lambda
((new-bstr_0 used_0 status_0)
(let ((done_0
(string->bytes/locale
(norm_0
(norm-tail_0
(bytes->string/locale new-bstr_0))))))
(if (eq? status_0 'complete)
done_0
(if (eq? status_0 'aborts)
(bytes-append
done_0
(subbytes bstr_0 (+ offset_0 used_0)))
(let ((app_0
(let ((app_0 (+ offset_0 used_0)))
(subbytes
bstr_0
app_0
(+ offset_0 used_0 1)))))
(bytes-append
done_0
app_0
(loop_0 bstr_0 c_0 (+ offset_0 used_0 1))))))))
(let ((s_0 (bytes->string/locale new-bstr_0)))
(let ((tail-s_0
(if (eq? status_0 'complete)
(norm-tail_0 s_0)
s_0)))
(let ((done_0
(string->bytes/locale (norm_0 tail-s_0))))
(if (eq? status_0 'complete)
done_0
(if (eq? status_0 'aborts)
(bytes-append
done_0
(subbytes bstr_0 (+ offset_0 used_0)))
(let ((app_0
(let ((app_0 (+ offset_0 used_0)))
(subbytes
bstr_0
app_0
(+ offset_0 used_0 1)))))
(bytes-append
done_0
app_0
(loop_0
bstr_0
c_0
(+ offset_0 used_0 1))))))))))
(args (raise-binding-result-arity-error 3 args))))))))
(norm-tail_0
(|#%name|
@ -3055,6 +3060,13 @@
(begin
(check-ranges who_0 type-name_0 vec_0 start_0 stop*_0 step_0 len_0)
(values vec_0 start_0 stop*_0 step_0)))))))
(define unsafe-normalise-inputs
(lambda (unsafe-vector-length_0 vec_0 start_0 stop_0 step_0)
(values
vec_0
start_0
(if stop_0 stop_0 (|#%app| unsafe-vector-length_0 vec_0))
step_0)))
(define check-vector
(lambda (v_0)
(if (vector? v_0) (void) (raise-argument-error 'in-vector "vector" v_0))))
@ -6953,9 +6965,7 @@
(define all-fields-immutable?
(lambda (k_0) (prefab-key-all-fields-immutable? k_0)))
(define datum-map-slow
(letrec ((procz2 (lambda (x_0) (unsafe-vector-length x_0)))
(procz1 (lambda (x_0) (vector? x_0)))
(loop_0
(letrec ((loop_0
(|#%name|
loop
(lambda (f_0 known-pairs_0 tail?_0 s_0 prev-seen_0)
@ -7100,11 +7110,8 @@
(reverse$1
(call-with-values
(lambda ()
(normalise-inputs
'in-vector
"vector"
procz1
procz2
(unsafe-normalise-inputs
unsafe-vector-length
(struct->vector s_0)
1
#f
@ -23261,11 +23268,7 @@
(define fasl-hash-equal-variant 1)
(define fasl-hash-eqv-variant 2)
(define s-exp->fasl.1
(letrec ((procz4 (lambda (x_0) (unsafe-vector-length x_0)))
(procz3 (lambda (x_0) (vector? x_0)))
(procz2 (lambda (x_0) (unsafe-vector-length x_0)))
(procz1 (lambda (x_0) (vector? x_0)))
(loop_0
(letrec ((loop_0
(|#%name|
loop
(lambda (external-lift?7_0
@ -23395,11 +23398,8 @@
c1_0)
(call-with-values
(lambda ()
(normalise-inputs
'in-vector
"vector"
procz1
procz2
(unsafe-normalise-inputs
unsafe-vector-length
(struct->vector v_0)
1
#f
@ -24009,11 +24009,8 @@
o_0)
(call-with-values
(lambda ()
(normalise-inputs
'in-vector
"vector"
procz3
procz4
(unsafe-normalise-inputs
unsafe-vector-length
vec_0
1
#f
@ -26072,13 +26069,7 @@
fold-var_0))))))
(for-loop_0 null phases-in-order_0)))))))))
(define generate-deserialize.1
(letrec ((procz6 (lambda (x_0) (unsafe-vector-length x_0)))
(procz5 (lambda (x_0) (vector? x_0)))
(procz4 (lambda (x_0) (unsafe-vector-length x_0)))
(procz3 (lambda (x_0) (vector? x_0)))
(procz2 (lambda (x_0) (unsafe-vector-length x_0)))
(procz1 (lambda (x_0) (vector? x_0)))
(finish_0
(letrec ((finish_0
(|#%name|
finish
(lambda (mutables_0
@ -26407,11 +26398,8 @@
(begin
(call-with-values
(lambda ()
(normalise-inputs
'in-vector
"vector"
procz1
procz2
(unsafe-normalise-inputs
unsafe-vector-length
(struct->vector v_0)
1
#f
@ -26459,11 +26447,8 @@
(begin
(call-with-values
(lambda ()
(normalise-inputs
'in-vector
"vector"
procz3
procz4
(unsafe-normalise-inputs
unsafe-vector-length
(struct->vector v_0)
1
#f
@ -26867,11 +26852,8 @@
(let ((all-quoted?_0
(call-with-values
(lambda ()
(normalise-inputs
'in-vector
"vector"
procz5
procz6
(unsafe-normalise-inputs
unsafe-vector-length
vec_0
1
#f
@ -28925,203 +28907,191 @@
"bad fill encoding: ~v"
(unsafe-vector*-ref vec_0 pos_0)))))))))))
(define find-reachable-scopes
(letrec ((procz2 (lambda (x_0) (unsafe-vector-length x_0)))
(procz1 (lambda (x_0) (vector? x_0))))
(lambda (v_0)
(let ((seen_0 (make-hasheq)))
(let ((reachable-scopes_0 (seteq)))
(let ((get-reachable-scopes_0
(lambda (v_0)
(let ((seen_0 (make-hasheq)))
(let ((reachable-scopes_0 (seteq)))
(let ((get-reachable-scopes_0
(|#%name|
get-reachable-scopes
(lambda () (begin reachable-scopes_0)))))
(let ((scope-triggers_0 (make-hasheq)))
(begin
(letrec*
((loop_0
(|#%name|
get-reachable-scopes
(lambda () (begin reachable-scopes_0)))))
(let ((scope-triggers_0 (make-hasheq)))
(begin
(letrec*
((loop_0
(|#%name|
loop
(lambda (v_1)
(begin
(if (interned-literal? v_1)
loop
(lambda (v_1)
(begin
(if (interned-literal? v_1)
(void)
(if (hash-ref seen_0 v_1 #f)
(void)
(if (hash-ref seen_0 v_1 #f)
(void)
(begin
(hash-set! seen_0 v_1 #t)
(if (scope-with-bindings? v_1)
(begin
(set! reachable-scopes_0
(let ((s_0 reachable-scopes_0))
(hash-set s_0 v_1 #t)))
(|#%app| (reach-scopes-ref v_1) v_1 loop_0)
(let ((lst_0
(hash-ref scope-triggers_0 v_1 null)))
(begin
(letrec*
((for-loop_0
(|#%name|
for-loop
(lambda (lst_1)
(begin
(if (pair? lst_1)
(let ((proc_0
(unsafe-car lst_1)))
(let ((rest_0
(unsafe-cdr lst_1)))
(begin
(|#%app| proc_0 loop_0)
(for-loop_0 rest_0))))
(values)))))))
(for-loop_0 lst_0))))
(void)
(hash-remove! scope-triggers_0 v_1)
(|#%app|
(scope-with-bindings-ref v_1)
v_1
get-reachable-scopes_0
loop_0
(lambda (sc-unreachable_0 b_0)
(let ((xform_0
(lambda (l_0) (cons b_0 l_0))))
(do-hash-update
'hash-update!
#t
hash-set!
scope-triggers_0
sc-unreachable_0
xform_0
null)))))
(if (reach-scopes? v_1)
(|#%app| (reach-scopes-ref v_1) v_1 loop_0)
(if (pair? v_1)
(begin
(loop_0 (car v_1))
(loop_0 (cdr v_1)))
(if (vector? v_1)
(begin
(call-with-values
(lambda ()
(begin
(check-vector v_1)
(values
v_1
(unsafe-vector-length v_1))))
(case-lambda
((vec_0 len_0)
(begin
#f
(letrec*
((for-loop_0
(|#%name|
for-loop
(lambda (pos_0)
(begin
(if (unsafe-fx<
pos_0
len_0)
(let ((e_0
(unsafe-vector-ref
vec_0
pos_0)))
(begin
(loop_0 e_0)
(for-loop_0
(unsafe-fx+
1
pos_0))))
(values)))))))
(for-loop_0 0))))
(args
(raise-binding-result-arity-error
2
args))))
(void))
(if (box? v_1)
(loop_0 (unbox v_1))
(if (hash? v_1)
(begin
(hash-set! seen_0 v_1 #t)
(if (scope-with-bindings? v_1)
(begin
(set! reachable-scopes_0
(let ((s_0 reachable-scopes_0))
(hash-set s_0 v_1 #t)))
(|#%app| (reach-scopes-ref v_1) v_1 loop_0)
(let ((lst_0
(hash-ref scope-triggers_0 v_1 null)))
(begin
(letrec*
((for-loop_0
(|#%name|
for-loop
(lambda (lst_1)
(begin
(begin
(letrec*
((for-loop_0
(|#%name|
for-loop
(lambda (i_0)
(begin
(if i_0
(call-with-values
(lambda ()
(hash-iterate-key+value
v_1
i_0))
(case-lambda
((k_0 v_2)
(begin
(begin
(loop_0 k_0)
(loop_0 v_2))
(for-loop_0
(hash-iterate-next
v_1
i_0))))
(args
(raise-binding-result-arity-error
2
args))))
(values)))))))
(for-loop_0
(hash-iterate-first v_1))))
(void))
(if (prefab-struct-key v_1)
(begin
(call-with-values
(lambda ()
(normalise-inputs
'in-vector
"vector"
procz1
procz2
(struct->vector v_1)
1
#f
1))
(case-lambda
((v*_0
start*_0
stop*_0
step*_0)
(if (pair? lst_1)
(let ((proc_0
(unsafe-car lst_1)))
(let ((rest_0
(unsafe-cdr lst_1)))
(begin
(|#%app| proc_0 loop_0)
(for-loop_0 rest_0))))
(values)))))))
(for-loop_0 lst_0))))
(void)
(hash-remove! scope-triggers_0 v_1)
(|#%app|
(scope-with-bindings-ref v_1)
v_1
get-reachable-scopes_0
loop_0
(lambda (sc-unreachable_0 b_0)
(let ((xform_0
(lambda (l_0) (cons b_0 l_0))))
(do-hash-update
'hash-update!
#t
hash-set!
scope-triggers_0
sc-unreachable_0
xform_0
null)))))
(if (reach-scopes? v_1)
(|#%app| (reach-scopes-ref v_1) v_1 loop_0)
(if (pair? v_1)
(begin (loop_0 (car v_1)) (loop_0 (cdr v_1)))
(if (vector? v_1)
(begin
(call-with-values
(lambda ()
(begin
(check-vector v_1)
(values
v_1
(unsafe-vector-length v_1))))
(case-lambda
((vec_0 len_0)
(begin
#f
(letrec*
((for-loop_0
(|#%name|
for-loop
(lambda (pos_0)
(begin
#t
(letrec*
((for-loop_0
(|#%name|
for-loop
(lambda (idx_0)
(if (unsafe-fx< pos_0 len_0)
(let ((e_0
(unsafe-vector-ref
vec_0
pos_0)))
(begin
(loop_0 e_0)
(for-loop_0
(unsafe-fx+
1
pos_0))))
(values)))))))
(for-loop_0 0))))
(args
(raise-binding-result-arity-error
2
args))))
(void))
(if (box? v_1)
(loop_0 (unbox v_1))
(if (hash? v_1)
(begin
(begin
(letrec*
((for-loop_0
(|#%name|
for-loop
(lambda (i_0)
(begin
(if i_0
(call-with-values
(lambda ()
(hash-iterate-key+value
v_1
i_0))
(case-lambda
((k_0 v_2)
(begin
(if (unsafe-fx<
idx_0
stop*_0)
(let ((e_0
(unsafe-vector-ref
v*_0
idx_0)))
(begin
(loop_0 e_0)
(for-loop_0
(unsafe-fx+
idx_0
1))))
(values)))))))
(for-loop_0 start*_0))))
(args
(raise-binding-result-arity-error
4
args))))
(void))
(if (srcloc? v_1)
(loop_0 (srcloc-source v_1))
(void)))))))))))))))))
(loop_0 v_0))
reachable-scopes_0))))))))
(begin
(loop_0 k_0)
(loop_0 v_2))
(for-loop_0
(hash-iterate-next
v_1
i_0))))
(args
(raise-binding-result-arity-error
2
args))))
(values)))))))
(for-loop_0
(hash-iterate-first v_1))))
(void))
(if (prefab-struct-key v_1)
(begin
(call-with-values
(lambda ()
(unsafe-normalise-inputs
unsafe-vector-length
(struct->vector v_1)
1
#f
1))
(case-lambda
((v*_0 start*_0 stop*_0 step*_0)
(begin
#t
(letrec*
((for-loop_0
(|#%name|
for-loop
(lambda (idx_0)
(begin
(if (unsafe-fx<
idx_0
stop*_0)
(let ((e_0
(unsafe-vector-ref
v*_0
idx_0)))
(begin
(loop_0 e_0)
(for-loop_0
(unsafe-fx+
idx_0
1))))
(values)))))))
(for-loop_0 start*_0))))
(args
(raise-binding-result-arity-error
4
args))))
(void))
(if (srcloc? v_1)
(loop_0 (srcloc-source v_1))
(void)))))))))))))))))
(loop_0 v_0))
reachable-scopes_0)))))))
(define deserialize-imports
'(deserialize-module-path-indexes
syntax-module-path-index-shift

1072
racket/src/cs/schemified/io.scm
View File

File diff suppressed because it is too large Load Diff

1967
racket/src/cs/schemified/regexp.scm
View File

File diff suppressed because it is too large Load Diff

38
racket/src/cs/schemified/schemify.scm
View File

@ -1942,6 +1942,13 @@
(begin
(check-ranges who_0 type-name_0 vec_0 start_0 stop*_0 step_0 len_0)
(values vec_0 start_0 stop*_0 step_0)))))))
(define unsafe-normalise-inputs
(lambda (unsafe-vector-length_0 vec_0 start_0 stop_0 step_0)
(values
vec_0
start_0
(if stop_0 stop_0 (|#%app| unsafe-vector-length_0 vec_0))
step_0)))
(define check-vector
(lambda (v_0)
(if (vector? v_0) (void) (raise-argument-error 'in-vector "vector" v_0))))
@ -48521,11 +48528,7 @@
(define fasl-hash-equal-variant 1)
(define fasl-hash-eqv-variant 2)
(define s-exp->fasl.1
(letrec ((procz4 (lambda (x_0) (unsafe-vector-length x_0)))
(procz3 (lambda (x_0) (vector? x_0)))
(procz2 (lambda (x_0) (unsafe-vector-length x_0)))
(procz1 (lambda (x_0) (vector? x_0)))
(loop_0
(letrec ((loop_0
(|#%name|
loop
(lambda (external-lift?7_0
@ -48655,11 +48658,8 @@
c1_0)
(call-with-values
(lambda ()
(normalise-inputs
'in-vector
"vector"
procz1
procz2
(unsafe-normalise-inputs
unsafe-vector-length
(struct->vector v_0)
1
#f
@ -49269,11 +49269,8 @@
o_0)
(call-with-values
(lambda ()
(normalise-inputs
'in-vector
"vector"
procz3
procz4
(unsafe-normalise-inputs
unsafe-vector-length
vec_0
1
#f
@ -57422,9 +57419,7 @@
(for-loop_0 args-stack_0 0)))))
(interpret-expr b_1 stack_0)))))))))))))
(define interpret-expr
(letrec ((procz2 (lambda (x_0) (unsafe-vector-length x_0)))
(procz1 (lambda (x_0) (vector? x_0)))
(apply-function_0
(letrec ((apply-function_0
(|#%name|
apply-function
(lambda (b_0 captured_0 args_0)
@ -57736,11 +57731,8 @@
(lambda ()
(call-with-values
(lambda ()
(normalise-inputs
'in-vector
"vector"
procz1
procz2
(unsafe-normalise-inputs
unsafe-vector-length
b64_0
2
#f

29
racket/src/cs/schemified/thread.scm
View File

@ -655,6 +655,13 @@
(begin
(check-ranges who_0 type-name_0 vec_0 start_0 stop*_0 step_0 len_0)
(values vec_0 start_0 stop*_0 step_0)))))))
(define unsafe-normalise-inputs
(lambda (unsafe-vector-length_0 vec_0 start_0 stop_0 step_0)
(values
vec_0
start_0
(if stop_0 stop_0 (|#%app| unsafe-vector-length_0 vec_0))
step_0)))
(define check-vector
(lambda (v_0)
(if (vector? v_0) (void) (raise-argument-error 'in-vector "vector" v_0))))
@ -3505,9 +3512,7 @@
(define 1/place-message-allowed?
(|#%name| place-message-allowed? (lambda (v_0) (begin (allowed?.1 #f v_0)))))
(define message-ize
(letrec ((procz2 (lambda (x_0) (unsafe-vector-length x_0)))
(procz1 (lambda (x_0) (vector? x_0)))
(loop_0
(letrec ((loop_0
(|#%name|
loop
(lambda (fail_0 graph_0 used_0 v_0)
@ -3681,11 +3686,8 @@
(reverse$1
(call-with-values
(lambda ()
(normalise-inputs
'in-vector
"vector"
procz1
procz2
(unsafe-normalise-inputs
unsafe-vector-length
(struct->vector v_0)
1
#f
@ -3961,9 +3963,7 @@
(make-reader-graph (do-un-message-ize (message-ized-unmessage v_0)))
v_0)))
(define do-un-message-ize
(letrec ((procz2 (lambda (x_0) (unsafe-vector-length x_0)))
(procz1 (lambda (x_0) (vector? x_0)))
(loop_0
(letrec ((loop_0
(|#%name|
loop
(lambda (graph_0 v_0)
@ -4063,11 +4063,8 @@
(reverse$1
(call-with-values
(lambda ()
(normalise-inputs
'in-vector
"vector"
procz1
procz2
(unsafe-normalise-inputs
unsafe-vector-length
(struct->vector v_0)
1
#f

10
racket/src/io/demo.rkt
View File

@ -828,7 +828,7 @@
(let loop ([j 10])
(unless (zero? j)
(let ()
(define p (open-input-file "compiled/io.rktl"))
(define p (open-input-file "../cs/schemified/io.scm"))
(port-count-lines! p)
(let loop ()
(define s (read-string 100 p))
@ -845,7 +845,7 @@
(let loop ([j 10])
(unless (zero? j)
(let ()
(define p (host:open-input-file "compiled/io.rktl"))
(define p (host:open-input-file "../cs/schemified/io.scm"))
(host:file-stream-buffer-mode p read-byte-buffer-mode)
(when count-lines? (host:port-count-lines! p))
(let loop ()
@ -859,7 +859,7 @@
(let loop ([j 10])
(unless (zero? j)
(let ()
(define p (open-input-file "compiled/io.rktl"))
(define p (open-input-file "../cs/schemified/io.scm"))
(file-stream-buffer-mode p read-byte-buffer-mode)
(when count-lines? (port-count-lines! p))
(let loop ()
@ -873,7 +873,7 @@
(let loop ([j 10])
(unless (zero? j)
(let ()
(define p (host:open-input-file "compiled/io.rktl"))
(define p (host:open-input-file "../cs/schemified/io.scm"))
(let loop ()
(unless (eof-object? (host:read-line p))
(loop)))
@ -885,7 +885,7 @@
(let loop ([j 10])
(unless (zero? j)
(let ()
(define p (open-input-file "compiled/io.rktl"))
(define p (open-input-file "../cs/schemified/io.scm"))
(let loop ()
(unless (eof-object? (read-line p))
(loop)))

19
racket/src/io/locale/recase.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "../common/check.rkt"
(require racket/fixnum
"../common/check.rkt"
"../host/thread.rkt"
"../host/rktio.rkt"
"../host/error.rkt"
@ -30,16 +31,16 @@
;; those directly
(define len (string-length s))
(let loop ([pos 0])
(define i-len (+ pos (string-length-up-to-nul s pos len)))
(define i-len (fx+ pos (string-length-up-to-nul s pos len)))
(cond
[(= i-len len)
[(fx= i-len len)
(define new-s (recase/no-nul (maybe-substring s pos len) up?))
(if (eqv? pos 0)
new-s
(list new-s))]
[else
(define new-s (recase/no-nul (substring s pos i-len) up?))
(define r (loop (+ i-len 1)))
(define r (loop (fx+ i-len 1)))
(if (eqv? pos 0)
(apply string-append new-s (string #\nul) r)
(cons new-s (cons (string #\nul) r)))])))
@ -47,13 +48,13 @@
(define (recase/no-nul s up?)
(cond
[(and (equal? (current-locale) "")
(not (zero? (bitwise-and (rktio_convert_properties rktio) RKTIO_CONVERT_RECASE_UTF16))))
(not (fx= 0 (fxand (rktio_convert_properties rktio) RKTIO_CONVERT_RECASE_UTF16))))
;; The OS provides a UTF-16-based function, so use that
(define s-16 (utf-16-encode s))
(start-atomic)
(define r (rktio_recase_utf16 rktio
up?
s-16 (arithmetic-shift (bytes-length s-16) -1)
s-16 (fxrshift (bytes-length s-16) 1)
#f))
(define sr (rktio_to_shorts r))
(rktio_free r)
@ -72,7 +73,7 @@
(lambda ()
(let loop ([pos 0])
(cond
[(= pos (bytes-length in-bstr))
[(fx= pos (bytes-length in-bstr))
(if (eqv? pos 0)
""
'(""))]
@ -90,8 +91,8 @@
ls
(list ls))]
[else
(define r (loop (+ pos in-used 4)))
(define err-s (string (string-ref s (arithmetic-shift (+ pos in-used) -2))))
(define r (loop (fx+ pos in-used 4)))
(define err-s (string (string-ref s (fxrshift (+ pos in-used) 2))))
(if (eqv? pos 0)
(apply string-append ls err-s r)
(list* ls err-s r))])])))

39
racket/src/io/string/utf-16-decode.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "../common/set-two.rkt")
(require racket/fixnum
"../common/set-two.rkt")
(provide utf-16-decode)
@ -8,34 +9,34 @@
(define (utf-16-decode bstr)
(define len (bytes-length bstr))
(define surrogate-count
(if (= len 0)
(if (fx= len 0)
0
(for/fold ([n 0]) ([b (in-bytes bstr (if big-endian? 0 1) len 2)])
(if (= (bitwise-and b #xDC) #xD8)
(add1 n)
(if (fx= (fxand b #xDC) #xD8)
(fx+ n 1)
n))))
(define str (make-string (- (arithmetic-shift len -1) surrogate-count)))
(define str (make-string (fx- (fxrshift len 1) surrogate-count)))
(let loop ([i 0] [pos 0])
(unless (= i len)
(unless (fx= i len)
(define a (bytes-ref bstr i))
(define b (bytes-ref bstr (add1 i)))
(define b (bytes-ref bstr (fx+ i 1)))
(define v (if big-endian?
(bitwise-ior (arithmetic-shift a 8) b)
(bitwise-ior (arithmetic-shift b 8) a)))
(fxior (fxlshift a 8) b)
(fxior (fxlshift b 8) a)))
(cond
[(= (bitwise-and v #xDC00) #xDC00)
[(fx= (fxand v #xDC00) #xDC00)
;; surrogate pair
(define a (bytes-ref bstr (+ i 2)))
(define b (bytes-ref bstr (+ i 3)))
(define a (bytes-ref bstr (fx+ i 2)))
(define b (bytes-ref bstr (fx+ i 3)))
(define v2 (if big-endian?
(bitwise-ior (arithmetic-shift a 8) b)
(bitwise-ior (arithmetic-shift b 8) a)))
(define all-v (+ #x10000
(bitwise-ior (arithmetic-shift (bitwise-and v #x3FF) 10)
(bitwise-and v2 #x3FF))))
(fxior (fxlshift a 8) b)
(fxior (fxlshift b 8) a)))
(define all-v (fx+ #x10000
(fxior (fxlshift (fxand v #x3FF) 10)
(fxand v2 #x3FF))))
(string-set! str pos (integer->char all-v))
(loop (+ i 4) (add1 pos))]
(loop (fx+ i 4) (fx+ pos 1))]
[else
(string-set! str pos (integer->char v))
(loop (+ i 2) (add1 pos))])))
(loop (fx+ i 2) (fx+ pos 1))])))
str)

27
racket/src/io/string/utf-16-encode.rkt
View File

@ -1,26 +1,27 @@
#lang racket/base
(require "../common/set-two.rkt")
(require racket/fixnum
"../common/set-two.rkt")
(provide utf-16-encode)
(define (utf-16-encode s)
(define surrogate-count
(for/fold ([n 0]) ([c (in-string s)])
(if ((char->integer c) . >= . #x10000)
(add1 n)
(if ((char->integer c) . fx>= . #x10000)
(fx+ n 1)
n)))
(define bstr (make-bytes (* 2 (+ (string-length s) surrogate-count))))
(define bstr (make-bytes (fx* 2 (fx+ (string-length s) surrogate-count))))
(for/fold ([pos 0]) ([c (in-string s)])
(define v (char->integer c))
(cond
[(v . >= . #x10000)
(define av (- v #x10000))
(define hi (bitwise-ior #xD800 (bitwise-and (arithmetic-shift av -10) #x3FF)))
(define lo (bitwise-ior #xDC00 (bitwise-and av #x3FF)))
(bytes-set-two! bstr pos (arithmetic-shift hi -8) (bitwise-and hi #xFF))
(bytes-set-two! bstr pos (arithmetic-shift lo -8) (bitwise-and lo #xFF))
(+ pos 4)]
[(v . fx>= . #x10000)
(define av (fx- v #x10000))
(define hi (fxior #xD800 (fxand (fxrshift av 10) #x3FF)))
(define lo (fxior #xDC00 (fxand av #x3FF)))
(bytes-set-two! bstr pos (fxrshift hi 8) (fxand hi #xFF))
(bytes-set-two! bstr pos (fxrshift lo 8) (fxand lo #xFF))
(fx+ pos 4)]
[else
(bytes-set-two! bstr pos (arithmetic-shift v -8) (bitwise-and v #xFF))
(+ pos 2)]))
(bytes-set-two! bstr pos (fxrshift v 8) (fxand v #xFF))
(fx+ pos 2)]))
bstr)

30
racket/src/io/string/utf-8-encode.rkt
View File

@ -27,21 +27,21 @@
out-bstr out-start out-end j
continue)
(cond
[(b . <= . #x7F)
[(b . fx<= . #x7F)
(cond
[(and out-end (= j out-end))
[(and out-end (fx= j out-end))
(values (fx- i in-start) (fx- j out-start) 'continues)]
[else
(when out-bstr (bytes-set! out-bstr j b))
(continue (fx+ j 1))])]
[(b . <= . #x7FF)
[(b . fx<= . #x7FF)
(cond
[(and out-end ((fx+ j 1) . fx>= . out-end))
(values (fx- i in-start) (fx- j out-start) 'continues)]
[else
(when out-bstr
(bytes-set! out-bstr j (bitwise-ior #b11000000 (arithmetic-shift b -6)))
(bytes-set! out-bstr (add1 j) (bitwise-ior #b10000000 (bitwise-and b #b111111))))
(bytes-set! out-bstr j (fxior #b11000000 (fxrshift b 6)))
(bytes-set! out-bstr (fx+ j 1) (fxior #b10000000 (fxand b #b111111))))
(continue (+ j 2))])]
[(b . fx<= . #xFFFF)
(cond
@ -49,10 +49,10 @@
(values (fx- i in-start) (fx- j out-start) 'continues)]
[else
(when out-bstr
(bytes-set! out-bstr j (bitwise-ior #b11100000 (arithmetic-shift b -12)))
(bytes-set! out-bstr (fx+ j 1) (bitwise-ior #b10000000 (bitwise-and (arithmetic-shift b -6)
#b111111)))
(bytes-set! out-bstr (fx+ j 2) (bitwise-ior #b10000000 (bitwise-and b #b111111))))
(bytes-set! out-bstr j (fxior #b11100000 (fxrshift b 12)))
(bytes-set! out-bstr (fx+ j 1) (fxior #b10000000 (fxand (fxrshift b 6)
#b111111)))
(bytes-set! out-bstr (fx+ j 2) (fxior #b10000000 (fxand b #b111111))))
(continue (fx+ j 3))])]
[else
(cond
@ -60,10 +60,10 @@
(values (fx- i in-start) (fx- j out-start) 'continues)]
[else
(when out-bstr
(bytes-set! out-bstr j (bitwise-ior #b11110000 (arithmetic-shift b -18)))
(bytes-set! out-bstr (fx+ j 1) (bitwise-ior #b10000000 (bitwise-and (arithmetic-shift b -12)
#b111111)))
(bytes-set! out-bstr (fx+ j 2) (bitwise-ior #b10000000 (bitwise-and (arithmetic-shift b -6)
#b111111)))
(bytes-set! out-bstr (fx+ j 3) (bitwise-ior #b10000000 (bitwise-and b #b111111))))
(bytes-set! out-bstr j (fxior #b11110000 (fxrshift b 18)))
(bytes-set! out-bstr (fx+ j 1) (fxior #b10000000 (fxand (fxrshift b 12)
#b111111)))
(bytes-set! out-bstr (fx+ j 2) (fxior #b10000000 (fxand (fxrshift b 6)
#b111111)))
(bytes-set! out-bstr (fx+ j 3) (fxior #b10000000 (fxand b #b111111))))
(continue (fx+ j 4))])]))