0. #lang at-exp racket
1.  
2. (require ; racket/fixnum
3.          racket/future
4.          scribble/srcdoc
5.          (for-doc scribble/manual
6.                   scribble-math/dollar))
7.  
8. (require racket/require
9.          (filtered-in
10.           (λ (name) (regexp-replace #rx"unsafe-" name ""))
11.           racket/unsafe/ops)
12.          (only-in
13.           racket/fixnum
14.           make-fxvector
15.           fxvector?))
16.  
17. (provide
18.  
19.  (proc-doc
20.   fxvector-futures-sort!
21.   (->i ((unsorted fxvector?))
22.        ((compare procedure?)
23.         #:progress-proc (progress-proc (or/c procedure? false?))
24.         #:progress-sleep (progress-sleep flonum?))
25.        (res fxvector?))
26.   ((λ (a b) (fx< a b)) #f 0.1)
27.   @{
28.  
29.     Sorts fxvector in place. If progress-proc is not #f, calls it
30. every progress-sleep seconds.
31.  
32.     The procedure uses merge sort with @${n} merge operations. Its
33. overall algorithmic time complexity is @${O(n\cdot\log_2 n)} and
34. memory complexity is @${O(n)}. The actual memory consumption is @${8n}
35. in addition to input of the same size on 64bit platforms.
36.  
37. The implementation uses all available processors.
38.  
39. If a custom compare function is provided, it should be a lambda term
40. and not a reference to some other function. For example, providing fx<
41. as compare blocks running in parallel, but using the default compare
42. function as is provides support for maximum parallelism.
43.  
44.     })
45.  
46.  (rename-out (futures-depth fxvector-util-futures-depth)
47.              (num-futures fxvector-util-num-futures))
48.  
49.  )
50.  
51. (define processors (processor-count))
52. (define futures-depth (inexact->exact (ceiling (log processors 2))))
53. (define num-futures (expt 2 futures-depth))
54.  
55. (define (fxvector-futures-sort! unsorted
56.                                 (compare (λ (a b) (fx< a b)))
57.                                 #:progress-proc (progress-proc #f)
58.                                 #:progress-sleep (progress-sleep 0.1))
59.   (define unsorted-length (fxvector-length unsorted))
60.   (define scratchpad (make-fxvector unsorted-length))
61.  
62.   (define total-merges (fx- unsorted-length 1))
63.  
64.   ; Create progresses vector, start progress thread and create stop
65.   ; procedure
66.   (define (create-progresses+stop)
67.     (define progresses (make-fxvector num-futures))
68.     (define progress-running #t)
69.     (define progress-thread
70.       (thread
71.        (λ ()
72.          (let loop ()
73.            (when progress-running
74.              (define progress
75.                (let loop ((i 0)
76.                           (acc 0))
77.                  (if (fx< i num-futures)
78.                      (loop (fx+ i 1)
79.                            (fx+ acc (fxvector-ref progresses i)))
80.                      acc)))
81.              (progress-proc progress total-merges)
82.              (sleep progress-sleep)
83.              (loop))))))
84.  
85.     ; Stops the loop and waits for the thread
86.     (define (progress-stop)
87.       (set! progress-running #f)
88.       (thread-wait progress-thread)
89.       (progress-proc total-merges total-merges))
90.  
91.     ; Must be assigned at once
92.     (values progresses progress-stop))
93.  
94.   ; Create progresses vector and stop proc if required
95.   (define-values
96.     (progresses progress-stop)
97.     (if progress-proc
98.         (create-progresses+stop)
99.         (values #f #f)))
100.  
101.   ; Generic merge stage
102.   (define (merge! from1 to1/from2 to2 depth fid)
103.     (when progress-proc
104.       (fxvector-set! progresses fid (fx+ (fxvector-ref progresses fid) 1)))
105.     (define src (if (fx= (fxand depth 1) 1) unsorted scratchpad))
106.     (define dst (if (fx= (fxand depth 1) 1) scratchpad unsorted))
107.     (let loop1 ((i from1)
108.                 (j to1/from2)
109.                 (k from1))
110.       ; Always select correct element based on compare function
111.       (cond
112.         ((and (fx< i to1/from2)
113.               (fx< j to2))
114.          (define v1 (fxvector-ref src i))
115.          (define v2 (fxvector-ref src j))
116.          (cond
117.            ((compare v1 v2)
118.             (fxvector-set! dst k v1)
119.             (loop1 (fx+ i 1) j (fx+ k 1)))
120.            (else
121.             (fxvector-set! dst k v2)
122.             (loop1 i (fx+ j 1) (fx+ k 1)))))
123.         (else
124.          (let loop2 ((i i)
125.                      (j j)
126.                      (k k))
127.            ; Finish from the first part
128.            (cond
129.              ((fx< i to1/from2)
130.               (fxvector-set! dst k (fxvector-ref src i))
131.               (loop2 (fx+ i 1) j (fx+ k 1)))
132.              (else
133.               (let loop3 ((i i)
134.                           (j j)
135.                           (k k))
136.                 ; Finish from the second part
137.                 (when (fx< j to2)
138.                   (fxvector-set! dst k (fxvector-ref src j))
139.                   (loop3 i (fx+ j 1) (fx+ k 1)))))))))))
140.  
141.   (define (sort-step from to (depth 0) (fid 0))
142.     (define cnt (fx- to from))
143.     (cond ((fx> cnt 2)
144.            ; >2 means we do a proper split/merge
145.            ; this is the only part to leverage futures
146.            (define cnt2 (fxrshift cnt 1))
147.            (define from1 from)
148.            (define to1/from2 (fx+ from cnt2))
149.            (define to2 to)
150.            (cond ((fx< depth futures-depth)
151.                   (let ((f1 (future
152.                              (λ ()
153.                                (sort-step from1 to1/from2
154.                                           (fx+ depth 1)
155.                                           fid)
156.                                #f)))
157.                         (f2 (future
158.                              (λ ()
159.                                (sort-step to1/from2 to2
160.                                           (fx+ depth 1)
161.                                           (fxior fid (fxlshift 1 depth)))
162.                                #f))))
163.                     (or (touch f1)
164.                         (touch f2))))
165.                  (else
166.                   (sort-step from1 to1/from2 (fx+ depth 1) fid)
167.                   (sort-step to1/from2 to2 (fx+ depth 1) fid)
168.                   ))
169.            (merge! from1 to1/from2 to2 depth fid))
170.           ((fx= cnt 2)
171.            (when progress-proc
172.              (fxvector-set! progresses fid (fx+ (fxvector-ref progresses fid) 1)))
173.            ; =2 - swap in-place or from the other
174.            (define v1 (fxvector-ref unsorted from))
175.            (define v2 (fxvector-ref unsorted (fx+ from 1)))
176.            (define dst (if (fx= (fxand depth 1) 1) scratchpad unsorted))
177.            (define v1first (compare v1 v2))
178.            (fxvector-set! dst
179.                           from
180.                           (if v1first v1 v2))
181.            (fxvector-set! dst
182.                           (fx+ from 1)
183.                           (if v1first v2 v1)))
184.           ((fx= cnt 1)
185.            ; =1 - only copy if it must go to scratchpad
186.            (when (fx= (fxand depth 1) 1)
187.              (fxvector-set! scratchpad from (fxvector-ref unsorted from))))
188.           ))
189.  
190.   ; Start with whole fxvector
191.   (sort-step 0 unsorted-length)
192.  
193.   ; Stop progress thread
194.   (when progress-proc
195.     (progress-stop))
196.  
197.   ; Return result
198.   unsorted)

=>