mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
1f74e4e97d
I thought that the case of sequential integers was already handled specially by the ASSOC transform but aparently not. Consequently +sigfpe-code-error-alist+ demanded a new MPH function when building for Haiku though the range of FPE_* constants is contiguous.
189 lines
9.9 KiB
Common Lisp
189 lines
9.9 KiB
Common Lisp
|
|
;; This is supposed to be representative of an alien enum.
|
|
(defvar *symbols*
|
|
'(:UNSPECIFIED-AIRCRAFT :|_123| :|_100| :|_141| :|_142| :|_143| :|_146| :|-14-F|
|
|
:|-14-X| :|-14-Y| :|-14-Z| :|_219| :|_220| :|_221| :|_223| :|_275| :|_290|
|
|
:|_295| :|_310| :|_312| :|_313| :|_318| :|_319| :|-31-A| :|-31-B| :|-31-F|
|
|
:|-31-N| :|-31-X| :|-31-Y| :|_320| :|_321| :|-32-A| :|-32-B| :|-32-F| :|-32-N|
|
|
:|-32-Q| :|-32-S| :|-32-X| :|_330| :|_332| :|_333| :|_338| :|_339| :|-33-B|
|
|
:|-33-F| :|-33-X| :|-33-Y| :|_340| :|_342| :|_343| :|_345| :|_346| :|_350|
|
|
:|_351| :|_358| :|_359| :|_377| :|-37-F| :|_380| :|_388| :|-38-F| :|_703|
|
|
:|_707| :|-70-F| :|-70-M| :|_717| :|_721| :|_722| :|_727| :|-72-A| :|-72-B|
|
|
:|-72-C| :|-72-F| :|-72-M| :|-72-S| :|-72-W| :|-72-X| :|-72-Y| :|_731| :|_732|
|
|
:|_733| :|_734| :|_735| :|_736| :|_737| :|_738| :|_739| :|-73-A| :|-73-C|
|
|
:|-73-E| :|-73-F| :|-73-G| :|-73-H| :|-73-J| :|-73-K| :|-73-L| :|-73-M|
|
|
:|-73-N| :|-73-P| :|-73-Q| :|-73-R| :|-73-S| :|-73-T| :|-73-U| :|-73-W|
|
|
:|-73-X| :|-73-Y| :|_741| :|_742| :|_743| :|_744| :|_747| :|-74-B| :|-74-C|
|
|
:|-74-D| :|-74-E| :|-74-F| :|-74-H| :|-74-J| :|-74-L| :|-74-M| :|-74-N|
|
|
:|-74-R| :|-74-T| :|-74-U| :|-74-V| :|-74-X| :|-74-Y| :|_752| :|_753| :|_757|
|
|
:|-75-C| :|-75-E| :|-75-F| :|-75-M| :|-75-T| :|-75-V| :|-75-W| :|_762| :|_763|
|
|
:|_764| :|_767| :|-76-F| :|-76-V| :|-76-W| :|-76-X| :|-76-Y| :|_772| :|_773|
|
|
:|_777| :|_779| :|-77-F| :|-77-L| :|-77-W| :|-77-X| :|_781| :|_783| :|_787|
|
|
:|_788| :|_789| :|-7-F8| :|-7-M1| :|-7-M7| :|-7-M8| :|-7-M9| :|-7-S7| :|-7-S8|
|
|
:|-7-S9| :|_919| :A22 :A26 :A28 :A30 :A32 :A38 :A40 :A58 :A78 :A81 :AB3 :AB4
|
|
:AB6 :ABB :ABF :ABX :ABY :ACD :ACP :ACT :AGH :AI4 :AN4 :AN6 :AN7 :ANF :APF
|
|
:APH :AR1 :AR7 :AR8 :ARJ :ARX :AT3 :AT4 :AT5 :AT7 :ATD :ATF :ATP :ATR :ATZ
|
|
:AW6 :AW8 :AWH :AX1 :AX8 :B11 :B12 :B13 :B14 :B15 :B72 :BE1 :BE2 :BE4 :BE9
|
|
:BEC :BEF :BEH :BEP :BES :BET :BH2 :BNI :BNT :BTA :BUS :C17 :C19 :C21 :C27
|
|
:C75 :CC6 :CC7 :CCJ :CCX :CD2 :CJ1 :CJ2 :CJ5 :CJ6 :CJ7 :CJ8 :CJL :CJM :CJS
|
|
:CJT :CJX :CL3 :CL4 :CL5 :CN1 :CN2 :CN7 :CNA :CNC :CNF :CNJ :CNT :CR1 :CR2
|
|
:CR5 :CR7 :CR9 :CRA :CRF :CRJ :CRK :CRV :CS1 :CS2 :CS3 :CS4 :CS5 :CS9 :CSB
|
|
:CV2 :CV4 :CV5 :CVF :CVR :CVV :CVX :CVY :CWC :D10 :D11 :D14 :D1-C :D1-F :D1-M
|
|
:D1-X :D1-Y :D20 :D28 :D2-L :D38 :D3-F :D3-X :D42 :D4-X :D62 :D6-F :D8-F :D8-L
|
|
:D8-M :D8-Q :D8-T :D8-X :D8-Y :D91 :D92 :D93 :D94 :D95 :D9-C :D9-D :D9-F :D9-L
|
|
:D9-S :D9-X :DAM :DC3 :DC4 :DC6 :DC8 :DC9 :DF1 :DF2 :DF3 :DF5 :DF7 :DF8 :DF9
|
|
:DFL :DH1 :DH2 :DH3 :DH4 :DH7 :DH8 :DHB :DHC :DHD :DHF :DHH :DHL :DHO :DHP
|
|
:DHR :DHS :DHT :E70 :E75 :E7-W :E90 :E95 :EA5 :EAC :EC3 :EC4 :EC5 :EC7 :EM2
|
|
:EM3 :EM4 :EM5 :EM7 :EM9 :EMB :EMJ :EML :EP1 :EP3 :EPH :EQV :ER3 :ER4 :ERD
|
|
:ERJ :ET5 :ET6 :ETR :EV5 :F21 :F22 :F23 :F24 :F27 :F28 :F50 :F5-F :F70 :FA7
|
|
:FK7 :FRJ :G2-B :G2-S :GA1 :GA5 :GA6 :GA8 :GJ2 :GJ3 :GJ4 :GJ5 :GJ6 :GJ7 :GR1
|
|
:GR2 :GR3 :GRG :GRJ :GRM :GRS :H16 :H20 :H21 :H24 :H25 :H28 :H29 :HBA :HEC
|
|
:HHJ :HOV :HPH :HS7 :HSF :I14 :I4-F :I9-F :ICE :IL4 :IL6 :IL7 :IL8 :IL9 :ILW
|
|
:J31 :J32 :J41 :JET :JST :JU5 :L10 :L11 :L12 :L15 :L1-A :L1-F :L49 :L4-F :L4-T
|
|
:LCH :LHP :LJ2 :LJ3 :LJ4 :LJ6 :LJ7 :LJ8 :LMO :LOE :LOF :LOH :LOM :LRJ :M11
|
|
:M1-F :M1-M :M2-F :M3-F :M6-F :M80 :M81 :M82 :M83 :M87 :M88 :M8-F :M90 :M95
|
|
:MA6 :MBH :MD9 :MIH :MTL :MU2 :ND2 :NDC :NDE :NDH :P18 :PA1 :PA2 :PAG :PAT
|
|
:PIG :PL2 :PL4 :PL6 :PN6 :PR1 :RFS :S20 :S58 :S61 :S76 :S9-S :SF3 :SF5 :SFA
|
|
:SFB :SFF :SH3 :SH6 :SHB :SHS :SSC :SU1 :SU7 :SU9 :SWF :SWM :SY8 :T12 :T20
|
|
:T2-F :T34 :TAT :TBM :TCM :TEE :TGV :THS :THT :TIC :TPT :TRD :TRN :TRS :TSL
|
|
:TU3 :TU5 :VCV :VGF :WWP :YK2 :YK4 :YM3 :YMC :YN2 :YN5 :YN7 :YS1)
|
|
)
|
|
|
|
(defun f (x)
|
|
(gethash x #.(let ((h (make-hash-table :size (length *symbols*)))
|
|
(val -100))
|
|
(dolist (sym *symbols* h)
|
|
(setf (gethash sym h) (incf val))))))
|
|
|
|
;;; See https://bugs.launchpad.net/sbcl/+bug/1980460
|
|
;;; We could add an expansion for CASE into ASSOC
|
|
;;; if the values of the case are constant.
|
|
|
|
(defun g (x)
|
|
(cdr (assoc x '#.(loop for x in *symbols* for i from -99 collect (cons x i)))))
|
|
|
|
(defun way1 (n syms)
|
|
(loop repeat (the fixnum n) sum (loop for x in syms sum (f x) fixnum)))
|
|
(defun way2 (n syms)
|
|
(loop repeat (the fixnum n) sum (loop for x in syms sum (g x) fixnum)))
|
|
|
|
(with-test (:name :fast-assoc :skipped-on :interpreter)
|
|
(let* ((inputs (append (shuffle *symbols*)
|
|
(reverse *symbols*)
|
|
(shuffle *symbols*)
|
|
*symbols*))
|
|
(begin-time (get-internal-real-time))
|
|
(answer1 (way1 10000 inputs))
|
|
(end-time-1 (get-internal-real-time))
|
|
(answer2 (way2 10000 inputs))
|
|
(end-time-2 (get-internal-real-time))
|
|
(elapsed1 (- end-time-1 begin-time))
|
|
(elapsed2 (- end-time-2 end-time-1)))
|
|
(assert (= answer1 answer2))
|
|
;; There isn't anything to assert about the speedup,
|
|
;; it's just an interesting number to see
|
|
(format t "Speedup=~F~%" (/ elapsed1 elapsed2))
|
|
(let* ((constants (ctu:find-code-constants #'g))
|
|
(key-vector (find-if #'simple-vector-p constants))
|
|
(data-vector
|
|
(find-if (lambda (x)
|
|
(and (vectorp x)
|
|
(not (eq x key-vector))
|
|
(= (length x) (length key-vector))))
|
|
constants)))
|
|
;; DATA are in a specialized vector. The perfect hash generator would
|
|
;; never use a signed-byte vector, so this has to be the data vector.
|
|
(assert (typep data-vector `(simple-array (signed-byte 16) (*)))))))
|
|
|
|
(with-test (:name :unoptimized-bad-code) ; lp#2054857
|
|
(flet ((try (expr)
|
|
(let ((f (compile nil `(lambda (a b)
|
|
(declare (muffle-conditions warning))
|
|
,expr))))
|
|
(assert-error (funcall f 1 'z)))))
|
|
(try '(cdr a (assoc b '((x) (y) (z)))))
|
|
(try '(cdr (assoc b '((x) (y) (z))) 1))))
|
|
|
|
(defglobal *my-alist* '((#\a . c) (#\b . :b) (#\c . see)
|
|
(#\d . d) (1 . foo) (foo . 32) (-4 . hello)))
|
|
(defun assoc-mixed-keytypes (x) (cdr (assoc x '#.*my-alist*)))
|
|
(defun rassoc-mixed-keytypes (x) (car (rassoc x '#.*my-alist*)))
|
|
(compile 'assoc-mixed-keytypes)
|
|
(compile 'rassoc-mixed-keytypes)
|
|
|
|
(with-test (:name :assoc-mixed-keytypes)
|
|
(let ((c (ctu:find-code-constants #'assoc-mixed-keytypes)))
|
|
(assert (typep (car c) '(simple-vector 7)))
|
|
(assert (typep (cadr c) '(simple-vector 7)))
|
|
(assert (not (cddr c))))
|
|
|
|
(let ((c (ctu:find-code-constants #'rassoc-mixed-keytypes)))
|
|
(assert (typep (car c) '(simple-vector 7)))
|
|
(assert (typep (cadr c) '(simple-vector 7)))
|
|
(assert (not (cddr c))))
|
|
|
|
(dolist (pair *my-alist*)
|
|
(assert (eql (assoc-mixed-keytypes (car pair)) (cdr pair)))
|
|
(assert (eql (rassoc-mixed-keytypes (cdr pair)) (car pair)))))
|
|
|
|
(defglobal *my-pos-testvector*
|
|
#(a #\_ :cmonkey nil :key 2 #\z #\space :zook -1 2 500))
|
|
(defun fast-rpos-mixed-keytypes (x)
|
|
(position x #.*my-pos-testvector* :from-end t))
|
|
(compile 'fast-rpos-mixed-keytypes)
|
|
(with-test (:name :pos-mixed-keytypes)
|
|
(let ((c (delete-if (lambda (x) (typep x '(or (vector * 8) integer)))
|
|
(ctu:find-code-constants #'fast-rpos-mixed-keytypes))))
|
|
(assert (typep (car c) '(simple-vector 11)))
|
|
(assert (typep (cadr c) '(vector (unsigned-byte 8) 11)))
|
|
(assert (not (cddr c))))
|
|
(dotimes (i (length *my-pos-testvector*))
|
|
(let* ((k (aref *my-pos-testvector* i))
|
|
(p (fast-rpos-mixed-keytypes k)))
|
|
(if (eql k 2) ; duplicated
|
|
(assert (= p 10))
|
|
(assert (= p i))))))
|
|
|
|
(sb-int:defconstant-eqx +averylongstring+
|
|
(map 'base-string 'code-char
|
|
'(94 44 61 78 122 124 90 68 104 113 63 90 111 49 101 89 96 106 116 39 81 82 54
|
|
52 66 100 123 78 95 51 55 124 111 83 124 110 40 39 124 115 94 42 105 102 102
|
|
78 56 126 81 10 94 117 103 53 40 88 119 104 90 48 75 48 68 88 78 50 65 41 115
|
|
117 120 51 63 72 63 96 33 32 112 70 106 43 94 96 50 101 88 66 87 88 60 76 99
|
|
91 90 45 87 89 90 102 10 85 115 102 57 51 107 54 125 81 44 57 38 66 91 64 71
|
|
119 101 103 51 42 34 125 55 122 42 65 36 66 85 92 65 58 46 84 41 98 53 101 95
|
|
104 40 71 78 108 105 126 54 116 93 59 108 61 60 37 43 111 72 85 108 109 90 65
|
|
73 50 97 45 103 62 102 49 52 90 56 119 77 107 93 111 69 114 125 64 55 96 122
|
|
119 108 69 92 106 65 73 55 67 122 87 74 111 46 36 103 109 103 115 75 106 74
|
|
113 62 63 86 55 89 69 84 35 115 49 67 106 54 68 110 47 114 95 44 90 41 59 88
|
|
94 34 33 63 10 56 109 103 60 105 40 53 125 40 51 42 91 100 47 67 46 96 89 118))
|
|
#'equal)
|
|
|
|
(with-test (:name :position-in-very-long-string)
|
|
;; This function should not crash the compiler.
|
|
;; The element type for the output array was getting choosen too restrictively.
|
|
;; Due to dup chars in the string, the vector of possible answers is only
|
|
;; as long as (length (remove-duplicates +averylongstring+)) but the element
|
|
;; is as large as (1- (length +averylongstring+)) inclusive.
|
|
(let ((f (compile nil '(lambda (c) (position c +averylongstring+)))))
|
|
(declare (notinline position))
|
|
;; the function should work
|
|
(dotimes (i (or #+sb-unicode 1000 256))
|
|
(assert (eql (position (code-char i) +averylongstring+)
|
|
(funcall f (code-char i)))))))
|
|
|
|
(defglobal *assoc-char-example*
|
|
'((#\g . 100) (#\d . 102) (#\i . 103) (#\f . 104) (#\e . 105)))
|
|
(defun rassoc-int-range (x) (car (rassoc x '#.*assoc-char-example*)))
|
|
(with-test (:name :assoc-dense-ranges)
|
|
(let* ((f (compile nil '(lambda (x) (cdr (assoc x '#.*assoc-char-example*)))))
|
|
(vector (car (ctu:find-code-constants f))))
|
|
(assert (equalp vector #(102 105 104 100 NIL 103)))
|
|
(dolist (x *assoc-char-example*)
|
|
(assert (eql (funcall f (car x)) (cdr x)))))
|
|
(let* ((f (compile nil '(lambda (x) (car (rassoc x '#.*assoc-char-example*)))))
|
|
(vector (car (ctu:find-code-constants f))))
|
|
(assert (equalp vector #(#\g NIL #\d #\i #\f #\e)))
|
|
(dolist (x *assoc-char-example*)
|
|
(assert (eql (funcall f (cdr x)) (car x))))))
|