-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathmergesort.lisp
143 lines (129 loc) · 7.29 KB
/
mergesort.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
(in-package :claws)
(defconstant +msort-grain-size+ #x3000)
(defgeneric stable-psort (sequence predicate &key key)
(:documentation "Parallel mergesort implementation, also known as cilksort. Good for large core counts and large collection sizes."))
(defmethod stable-psort ((list list) predicate &rest args &key key)
(declare (list list) (ignore key) (dynamic-extent args) #.*optimization*)
(if (list-length-less list +msort-grain-size+)
(apply #'stable-sort list predicate args)
(coerce (apply #'stable-psort (coerce list 'simple-vector) predicate args) 'list)))
(defmethod stable-psort :around ((vector vector) predicate &rest args &key key)
(declare (vector vector) (dynamic-extent args) #.*optimization*)
(if (< (length vector) +msort-grain-size+)
(apply #'stable-sort vector predicate args)
(apply #'call-next-method vector (get-function predicate) :key (if key (get-function key) #'identity) args)))
;; See https://en.wikipedia.org/wiki/Introduction_to_Algorithms and
;; https://www.clear.rice.edu/comp422/lecture-notes/ for details on the algorithm.
(defmacro define-stable-psort-vector (type ref)
`(defmethod stable-psort ((vector ,type) predicate &key key)
(declare (,type vector) (function predicate key) #.*optimization*)
(let* ((size (length vector)) (a (make-array size :element-type (array-element-type vector))))
(declare (fixnum size) (,type a))
(labels ((binary-search-eq (x v p r)
(declare (fixnum x p r) (,type v))
(let ((low p) (high (1+ r)))
(declare (fixnum low high))
(when (> low high)
(return-from binary-search-eq low))
(loop with xv = (funcall key (,ref v x))
while (< low high) do
(let ((mid (ash (+ low high) -1)))
(declare (fixnum mid))
(if (not (funcall predicate (funcall key (,ref v mid)) xv))
(setq high mid)
(setq low (1+ mid)))))
high))
(binary-search-neq (x v p r)
(declare (fixnum x p r) (,type v))
(let ((low p) (high (1+ r)))
(declare (fixnum low high))
(when (> low high)
(return-from binary-search-neq low))
(loop with xv = (funcall key (,ref v x))
while (< low high) do
(let ((mid (ash (+ low high) -1)))
(declare (fixnum mid))
(if (funcall predicate xv (funcall key (,ref v mid)))
(setq high mid)
(setq low (1+ mid)))))
high))
(smerge (v p1 r1 p2 r2 a p3)
(declare (,type v a) (fixnum p1 r1 p2 r2 p3))
(loop
(when (> p2 r2)
(replace a v :start1 p3 :start2 p1 :end2 (1+ r1))
(return))
(let ((q1 p1))
(declare (fixnum q1))
(when (<= p1 r1)
(let ((v2 (funcall key (,ref v p2))))
(when (not (funcall predicate v2 (funcall key (,ref v p1))))
(incf p1)
(loop while (and (<= p1 r1) (not (funcall predicate v2 (funcall key (,ref v p1))))) do (incf p1)))))
(replace a v :start1 p3 :start2 q1 :end2 p1)
(incf p3 (- p1 q1)))
(when (> p1 r1)
(replace a v :start1 p3 :start2 p2 :end2 (1+ r2))
(return))
(let ((q2 p2))
(declare (fixnum q2))
(when (<= p2 r2)
(let ((v1 (funcall key (,ref v p1))))
(when (funcall predicate (funcall key (,ref v p2)) v1)
(incf p2)
(loop while (and (<= p2 r2) (funcall predicate (funcall key (,ref v p2)) v1)) do (incf p2)))))
(replace a v :start1 p3 :start2 q2 :end2 p2)
(incf p3 (- p2 q2)))))
(pmerge (v p1 r1 p2 r2 a p3)
(declare (,type v a) (fixnum p1 r1 p2 r2 p3))
(let ((n1 (1+ (- r1 p1)))
(n2 (1+ (- r2 p2))))
(declare (fixnum n1 n2))
(when (< (+ n1 n2) +msort-grain-size+)
(smerge v p1 r1 p2 r2 a p3)
(return-from pmerge))
(cond ((> n1 n2)
(when (= n1 0) (return-from pmerge))
(let* ((q1 (ash (+ p1 r1) -1))
(q2 (binary-search-eq q1 v p2 r2))
(q3 (+ p3 (- q1 p1) (- q2 p2))))
(declare (fixnum q1 q2 q3))
(setf (,ref a q3) (,ref v q1))
(spawn () (pmerge v p1 (1- q1) p2 (1- q2) a p3))
(pmerge v (1+ q1) r1 q2 r2 a (1+ q3))
(sync)))
(t (when (= n2 0) (return-from pmerge))
(let* ((q2 (ash (+ p2 r2) -1))
(q1 (binary-search-neq q2 v p1 r1))
(q3 (+ p3 (- q1 p1) (- q2 p2))))
(declare (fixnum q1 q2 q3))
(setf (,ref a q3) (,ref v q2))
(spawn () (pmerge v p1 (1- q1) p2 (1- q2) a p3))
(pmerge v q1 r1 (1+ q2) r2 a (1+ q3))
(sync))))))
(recur (index size)
(declare (fixnum index size))
(cond ((< size +msort-grain-size+)
(stable-sort (make-array size :displaced-to vector :displaced-index-offset index) predicate :key key))
(t (let* ((q1 (ash size -2))
(q2 (+ q1 q1))
(q3 (+ q2 q1)))
(declare (fixnum q1 q2 q3))
(spawn () (recur index q1))
(spawn () (recur (+ index q1) q1))
(spawn () (recur (+ index q2) q1))
(recur (+ index q3) (- size q3))
(sync)
(spawn () (pmerge vector index (1- (+ index q1)) (+ index q1) (1- (+ index q2)) a index))
(pmerge vector (+ index q2) (1- (+ index q3)) (+ index q3) (1- (+ index size)) a (+ index q2))
(sync)
(pmerge a index (1- (+ index q2)) (+ index q2) (1- (+ index size)) vector index))))))
(recur 0 size))
vector)))
(define-stable-psort-vector vector aref)
(define-stable-psort-vector simple-vector svref)
(define-stable-psort-vector string char)
(define-stable-psort-vector simple-string schar)
(define-stable-psort-vector simple-base-string #+lispworks lw:sbchar #-lispworks schar)
(define-stable-psort-vector bit-vector bit)
(define-stable-psort-vector simple-bit-vector sbit)