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

Use unsafe operations for dealing with the vectors and indexes.

Browse Source 
svn: r17007
This commit is contained in:
Eli Barzilay 2009-11-23 18:51:03 +00:00
parent ea94f5dea5
commit 0b6ae05e9b
1 changed files with 41 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
collects/scheme/private/sort.ss
View File

@ -24,6 +24,14 @@ doing these checks.
|# |#
(#%require (rename '#%unsafe i+ unsafe-fx+)
(rename '#%unsafe i- unsafe-fx-)
(rename '#%unsafe i= unsafe-fx=)
(rename '#%unsafe i< unsafe-fx<)
(rename '#%unsafe i<= unsafe-fx<=)
(rename '#%unsafe i>> unsafe-fxrshift)
(rename '#%unsafe vref unsafe-vector-ref)
(rename '#%unsafe vset! unsafe-vector-set!))
(define sort (let () (define sort (let ()
@ -33,11 +41,11 @@ doing these checks.
(define-syntax foo (syntax-rules () [(_ . pattern) template]))])) (define-syntax foo (syntax-rules () [(_ . pattern) template]))]))
(define-syntax-rule (sort-internal-body v *<? n has-getkey? getkey) (define-syntax-rule (sort-internal-body v *<? n has-getkey? getkey)
(let* ([n/2- (arithmetic-shift n -1)] [n/2+ (- n n/2-)]) (let* ([n/2- (i>> n 1)] [n/2+ (i- n n/2-)])
(define-syntax-rule (<? x y) (define-syntax-rule (<? x y)
(if has-getkey? (*<? (getkey x) (getkey y)) (*<? x y))) (if has-getkey? (*<? (getkey x) (getkey y)) (*<? x y)))
(define-syntax-rule (ref n) (vector-ref v n)) (define-syntax-rule (ref n) (vref v n))
(define-syntax-rule (set! n x) (vector-set! v n x)) (define-syntax-rule (set! n x) (vset! v n x))
(define-syntax-rule (merge lo? A1 A2 B1 B2 C1) (define-syntax-rule (merge lo? A1 A2 B1 B2 C1)
(let ([b2 B2]) (let ([b2 B2])
@ -45,49 +53,49 @@ doing these checks.
(let ([x (ref a1)] [y (ref b1)]) (let ([x (ref a1)] [y (ref b1)])
(if (if lo? (not (<? y x)) (<? x y)) (if (if lo? (not (<? y x)) (<? x y))
(begin (set! c1 x) (begin (set! c1 x)
(let ([a1 (add1 a1)] [c1 (add1 c1)]) (let ([a1 (i+ a1 1)] [c1 (i+ c1 1)])
(when (< c1 b1) (loop a1 b1 c1)))) (when (i< c1 b1) (loop a1 b1 c1))))
(begin (set! c1 y) (begin (set! c1 y)
(let ([b1 (add1 b1)] [c1 (add1 c1)]) (let ([b1 (i+ b1 1)] [c1 (i+ c1 1)])
(if (<= b2 b1) (if (i<= b2 b1)
(let loop ([a1 a1] [c1 c1]) (let loop ([a1 a1] [c1 c1])
(when (< c1 b1) (when (i< c1 b1)
(set! c1 (ref a1)) (set! c1 (ref a1))
(loop (add1 a1) (add1 c1)))) (loop (i+ a1 1) (i+ c1 1))))
(loop a1 b1 c1))))))))) (loop a1 b1 c1)))))))))
(define-syntax-rule (copying-insertionsort Alo Blo n) (define-syntax-rule (copying-insertionsort Alo Blo n)
(let iloop ([i 0] [A Alo]) (let iloop ([i 0] [A Alo])
(when (< i n) (when (i< i n)
(let ([ref-i (ref A)]) (let ([ref-i (ref A)])
(let jloop ([j (+ Blo i)]) (let jloop ([j (i+ Blo i)])
(let ([ref-j-1 (ref (sub1 j))]) (let ([ref-j-1 (ref (i- j 1))])
(if (and (> j Blo) (<? ref-i ref-j-1)) (if (and (i< Blo j) (<? ref-i ref-j-1))
(begin (set! j ref-j-1) (jloop (sub1 j))) (begin (set! j ref-j-1) (jloop (i- j 1)))
(begin (set! j ref-i) (iloop (add1 i) (add1 A)))))))))) (begin (set! j ref-i) (iloop (i+ i 1) (i+ A 1))))))))))
(define (copying-mergesort Alo Blo n) (define (copying-mergesort Alo Blo n)
;; n is never 0, smaller values are more frequent
(cond (cond
[(= n 1) (set! Blo (ref Alo))] ;; n is never 0, smaller values are more frequent
[(= n 2) (let ([x (ref Alo)] [y (ref (add1 Alo))]) [(i= n 1) (set! Blo (ref Alo))]
(if (<? y x) [(i= n 2) (let ([x (ref Alo)] [y (ref (i+ Alo 1))])
(begin (set! Blo y) (set! (add1 Blo) x)) (if (<? y x)
(begin (set! Blo x) (set! (add1 Blo) y))))] (begin (set! Blo y) (set! (i+ Blo 1) x))
[(n . < . 16) ; not much difference up to ~30 (begin (set! Blo x) (set! (i+ Blo 1) y))))]
(copying-insertionsort Alo Blo n)] ;; insertion sort for small chunks (not much difference up to ~30)
[else (let* ([n/2- (arithmetic-shift n -1)] [n/2+ (- n n/2-)]) [(i< n 16) (copying-insertionsort Alo Blo n)]
(let ([Amid1 (+ Alo n/2-)] [else (let* ([n/2- (i>> n 1)] [n/2+ (i- n n/2-)])
[Amid2 (+ Alo n/2+)] (let ([Amid1 (i+ Alo n/2-)]
[Bmid1 (+ Blo n/2-)]) [Amid2 (i+ Alo n/2+)]
[Bmid1 (i+ Blo n/2-)])
(copying-mergesort Amid1 Bmid1 n/2+) (copying-mergesort Amid1 Bmid1 n/2+)
(copying-mergesort Alo Amid2 n/2-) (copying-mergesort Alo Amid2 n/2-)
(merge #t Amid2 (+ Alo n) Bmid1 (+ Blo n) Blo)))])) (merge #t Amid2 (i+ Alo n) Bmid1 (i+ Blo n) Blo)))]))
(let ([Alo 0] [Amid1 n/2-] [Amid2 n/2+] [Ahi n] [B1lo n]) (let ([Alo 0] [Amid1 n/2-] [Amid2 n/2+] [Ahi n] [B1lo n])
(copying-mergesort Amid1 B1lo n/2+) (copying-mergesort Amid1 B1lo n/2+)
(unless (zero? n/2-) (copying-mergesort Alo Amid2 n/2-)) (unless (zero? n/2-) (copying-mergesort Alo Amid2 n/2-))
(merge #f B1lo (+ B1lo n/2+) Amid2 Ahi Alo)))) (merge #f B1lo (i+ B1lo n/2+) Amid2 Ahi Alo))))
(define sort-internals (make-hasheq)) (define sort-internals (make-hasheq))
(define _ (define _
@ -102,16 +110,16 @@ doing these checks.
(precomp string-ci<? string-ci<=?) (precomp string-ci<? string-ci<=?)
(precomp keyword<?))) (precomp keyword<?)))
(define sort-internal (define-syntax sort-internal
(case-lambda (syntax-rules ()
[(<? vec n) [(_ <? vec n)
(let ([si (hash-ref sort-internals <? #f)]) (let ([si (hash-ref sort-internals <? #f)])
(if si (if si
;; use a precompiled function if found ;; use a precompiled function if found
(si vec n) (si vec n)
;; otherwise, use the generic code ;; otherwise, use the generic code
(let () (sort-internal-body vec <? n #f #f))))] (let () (sort-internal-body vec <? n #f #f))))]
[(<? vec n getkey) [(_ <? vec n getkey)
(let () (sort-internal-body vec <? n #t getkey))])) (let () (sort-internal-body vec <? n #t getkey))]))
(define-syntax-rule (sort-body lst *<? has-getkey? getkey cache-keys?) (define-syntax-rule (sort-body lst *<? has-getkey? getkey cache-keys?)